【发布时间】：2021-06-10 20:05:23
【问题描述】：
我的闪亮传单地图出现了故障，希望能得到一些帮助。
此地图旨在显示不同物种在两个不同采样年份的分布。在应用程序中，您可以选择要查看的物种和样本年份，如果需要，您可以选择自定义阈值以在地图上查看（例如，仅显示 50-200 只青蛙的颜色方块）。
地图运行良好，大部分情况下。我遇到的问题是自定义阈值输入基于 renderUI 输入（滑块值）构建调色板，如果您在选择“自定义阈值”时尝试切换物种，则会出现故障。基本上正在发生的事情是应用程序首先尝试为旧物种构建调色板并以这种方式投影栅格地图，然后快速更新到新物种。
这在实践中意味着如果您打开了“自定义阈值”，并且您从青蛙（具有下限）的投影分布转移到蟾蜍，地图首先使用旧青蛙阈值渲染，然后快速重新- 使用更新的（蟾蜍）输入值进行渲染。当您从蟾蜍（最高限度的物种）到青蛙的另一种方式时，应用程序崩溃，因为调色板试图用旧的、更高的限度（来自蟾蜍的数量）构建，这超出了青蛙的可能值。特定的行是使用“times”参数构建调色板。它在下面的代码中注明。
谢谢！
options("rgdal_show_exportToProj4_warnings"="none") # mute warnings from rgdal because I'm using proj strings
library(shiny)
library(shinyWidgets)
library(leaflet)
library(raster)
set.seed(1)
frog <- data.frame(x=sample(seq(from=-105, to=-95,by=.4), 300, replace = T),
y = sample(seq(from=35, to=45,by=.4), 300, replace=T),
sample1 = runif(300,min=10, max = 230),
sample2 = runif(300,min=10, max = 230))
toad <- data.frame(x=sample(seq(from=-105, to=-95,by=.4), 500, replace = T),
y = sample(seq(from=35, to=45,by=.4), 500, replace=T),
sample1 = runif(500,min=100, max = 900),
sample2 = runif(500,min=100, max = 900))
# Define UI for application that draws a map of species occurrences
ui <- fluidPage(
# Application title
titlePanel("Finding Frogs and Toads"),
# Sidebar with a selections for species, sample number, and custom thresholds
sidebarLayout(
sidebarPanel(
# Widget specifying the species to be included on the plot - starts on Frog
radioGroupButtons(
inputId = "species",
label = "Target Species",
choiceNames = list("Frog",
"Toad"),
choiceValues = list("frog","toad"),
selected = "frog",
justified = TRUE,
status= "primary"
),
# Widget specifying the sample to be displayed
selectInput("sample",
"Select sample",
choices = list("1" = "1",
"2" = "2"),
selected = "1",
),
# button to specify custom input y/n
switchInput(
inputId = "custom",
label = "Custom Threshold",
labelWidth = "100%"
),
# ui unpit to set custom thresholds to show in plot
uiOutput("reactive_slider")
),
# Show a plot of the generated distribution
mainPanel(
column(width = 12,
# Leaflet map
leafletOutput('map', height = "90vh"),
),
)
)
)
# Define server logic ---------------------------------------------------------
server <- function(input, output) {
# set limits for scales, dependent on species
spp_lim <- reactive({
switch(input$species,
"frog" = c(0:250), # highest frog density is 250
"toad" = c(0:1000), # highest toad density is 1000
)
})
# make start values for the reactive slider
slider_startvals <- reactiveValues(start = c(NA,NA))
observe({
if(input$species=="frog"){
slider_startvals$start <- c(20,160)
}
if(input$species=="toad"){
slider_startvals$start <- c(150,500)
}
})
# make the reactive slider to choose thresholds to view
output$reactive_slider <- renderUI(
sliderInput("reactive_slider", label = "Slider Range",
min = 0,
max = max(spp_lim()), # total scale limits dependent on species
value = slider_startvals$start # set sliders to start values above
)
) # end output reactive_slider
# create palette for map, based either on species limits, or on manual input from slider
map_pal <- reactiveValues()
observe({
# if custom threshoild limit button is not selected, show with Viridis scale
if (input$custom == "FALSE"){
map_pal$pal <- colorNumeric(palette = "plasma",
spp_lim(),
na.color = "transparent",
reverse=F)
} else{
# if custom thresholds limit is selected, build a palette of grey / purple / grey using custom slider inputs
# NOTE: these "times" arguments are the problem piece!
# when species is changed, the palette tries to build with the OLD slider values,
# which don't exist because they are out of range when moving from toad to frog,
# or are too low when moving frog to toad.
map_pal$pal <- colorNumeric(palette = c(rep(c("grey70"), times = input$reactive_slider[1]),
rep(c("purple"), times = (input$reactive_slider[2]-input$reactive_slider[1])),
rep(c("grey70"), times = (max(spp_lim())-input$reactive_slider[2])) ),
domain = spp_lim(),
na.color="transparent",
reverse=F)
}
})
# make a reverse palette for legend - same as above, but in reverse
map_pal_rev <- reactiveValues()
observe({
if (input$custom == "FALSE"){
map_pal_rev$pal <- colorNumeric(palette = "plasma",
spp_lim(),
na.color = "transparent",
reverse=T)
} else{ # then with set thresholds
# again, the "times" argument is the problematic piece, see above.
map_pal_rev$pal <- colorNumeric(palette = c(rep(c("grey70"), times = input$reactive_slider[1]),
rep(c("purple"), times = (input$reactive_slider[2]-input$reactive_slider[1])),
rep(c("grey70"), times = (max(spp_lim())-input$reactive_slider[2])) ),
domain = spp_lim(),
na.color="transparent",
reverse=T)
}
})
# make reactive data from input species dataset and sample number
map_dat <- reactive({
get(input$species) %>%
dplyr::select(x,y,paste0("sample",input$sample))
})
# rasterize map data object
map_dat_raster <- reactive({
rasterFromXYZ(map_dat(),
crs = "+init=epsg:4326 +proj=longlat +ellps=WGS84 ")
})
# make blank map
output$map <- renderLeaflet({
leaflet('map', options = leafletOptions(minZoom = 3, maxZoom = 7, zoomControl = TRUE)) %>%
addProviderTiles("CartoDB.VoyagerNoLabels") %>%
setView(lng = -100, lat = 46, zoom = 4)
}) # end render map
# add proxy for showing raster object
observe({
pal <- map_pal$pal
dfr <- map_dat_raster()
leafletProxy("map") %>%
clearImages() %>%
addRasterImage(dfr, colors = pal, opacity = 0.7,
project=TRUE)
})
# add proxy for legend opject
observe({
pal <- map_pal_rev$pal # this uses the reverse palette because I want it high-to-low
leafletProxy("map") %>%
clearControls() %>%
addLegend(position = "bottomright",
pal = pal,
values = spp_lim(),
title = paste0(stringr::str_to_title(input$species)," density (kg/km2)"),
opacity = 1,
labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
【问题讨论】：
标签： r shiny leaflet reactive shiny-server