我在闪亮的框架内有以下R代码。一切看起来都不错，但有传说（Plese see this screenshot）。
我希望根据用户选择的年龄段（60 +，65 +，85 +），性别或年份来更新图例。但事实并非如此。也就是说，无论从左侧菜单（Please see this screenshot）中选择什么，图例的值均保持不变。如果选择85+，这将使地图无用。以下是我的全部代码。
我感谢您的帮助。
纳德
load("/Users/nadermehri/Desktop/map codes/nhmap.RData")
library(shiny)
library(leaflet)
ui <- fluidPage(
tabPanel(
"Interactive Maps",
tags$h5 (
)),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "Age_Group_map",
label = "Select the Age Group:",
selected = "60+",
selectize = F,
multiple = F,
choices = sort(unique(nhmap$Age_Group))
),
radioButtons(
inputId = "sex_map",
label = strong("Select Sex:"),
selected = "Both Sexes",
choices = sort(unique(nhmap$Sex))
),
sliderInput(
inputId = "Year_map",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 10,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
)),
mainPanel("Interactive", leafletOutput("int_map", height=500))))
server <- function(input, output) {
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
return(out_map)
})
output$int_map <- renderLeaflet ({
leaflet (mapdata_(),
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837") ,
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per), na.color = "#808080", alpha = FALSE, reverse = F)) %>%
addProviderTiles("CartoDB.Positron") %>%
clearControls() %>%
clearShapes()%>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T),
label=~NAME) %>%
addTiles() %>%
setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat(
))
})
}
shinyApp(ui = ui, server = server)
答案 0 :(得分：0)
您必须在colorBin中定义分档，要在这些分档处剪切不同颜色部分中的数据。像这样：
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
na.color = "#808080", alpha = FALSE, reverse = F)
您还必须从bins= 4调用中删除addLegend，因为它将从调色板中获取信息。
我为nhmap创建了一些随机数据，该代码对我有用：
library(shiny)
library(leaflet)
library(sf)
library(sp)
## Random Data #############
data(meuse, package = "sp")
nhmap <- st_as_sf(meuse, coords = c("x", "y"))
st_crs(nhmap) <- "+init=epsg:28992"
nhmap <- st_buffer(nhmap, 100)
n = length(nhmap$cadmium)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Sex <- sample(c("m","f"), size = n, T)
nhmap$Per <- runif(n, 1, 150)
nhmap$NAME <- sample(c("a","b","c"), size = n, T)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Year <- sample(c(2010,2020,2030, 2040, 2050), size = n, T)
nhmap <- st_transform(nhmap, 4326)
## UI ###########
ui <- {fluidPage(
tabPanel(
"Interactive Maps",
tags$h5 ()),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "Age_Group_map",
label = "Select the Age Group:",
# selected = "60+",
selectize = F,
multiple = F,
choices = sort(unique(nhmap$Age_Group))
),
radioButtons(
inputId = "sex_map",
label = strong("Select Sex:"),
# selected = "Both Sexes",
choices = sort(unique(nhmap$Sex))
),
sliderInput(
inputId = "Year_map",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 10,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
)),
mainPanel("Interactive", leafletOutput("int_map", height=500)))
)}
## SERVER ###########
server <- function(input, output) {
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
# nhmap
nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
})
output$int_map <- renderLeaflet ({
req(mapdata_())
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
# pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per),
na.color = "#808080", alpha = FALSE, reverse = F)
leaflet(data = mapdata_()) %>%
# leaflet(data = nhmap) %>%
clearControls() %>%
clearShapes()%>%
addProviderTiles("CartoDB.Positron") %>%
addTiles() %>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
label=~NAME,
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T)) %>%
# setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)),
pal = pal
)
})
}
shinyApp(ui = ui, server = server)
答案 1 :(得分：0)
这是答案。正如我在上一条评论中提到的那样，好朋友需要保持被动：
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
return(out_map)
list(Per)
})
mapdata_1 <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map_1 <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map
)
return(out_map_1)
list(Per)
})
output$int_map <- renderLeaflet ({
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
pal <- colorBin(palette = pal8, domain =NULL, bins=quantile(mapdata_1()$Per), na.color = "#808080", alpha = FALSE, reverse = F)
leaflet (mapdata_()) %>%
addProviderTiles("CartoDB.Positron") %>%
clearControls() %>%
clearShapes()%>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T),
label=~NAME) %>%
addTiles() %>%
setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat(
))
})