反应性传单地图无法识别第二个调色板
Reactive Leaflet Map Not Recognizing 2nd Color Palette
我发布了一个类似的问题，但我的示例不够精简，因此我尝试减少一些。那么问题来了：
我正在从事一个 COVID19 项目，以可视化病毒在世界范围内的传播。我有一张世界等值线图，它使用日期滑块根据国家/地区的病例数和死亡人数更新地图。我有一个按钮可以通过按人口调整指标来更新地图。
我根据数据是否针对人口进行了调整，为地图创建了两组 color/bin/palette 控件。未调整数据时，地图上的颜色似乎与 bin 颜色类别适当相关，但当我针对人口进行调整时，颜色似乎不会随新的 bin 颜色类别更新。它们似乎与第一个 bin 颜色类别相关。
例如，当我想查看针对人口调整后的累计病例和累计死亡人数时，数字要小得多，但新的调色板仍然与原始调色板相关联（对于未调整的指标），所以看起来没有 data/extremely 低计数。
//忽略地图中缺失的国家//
我认为问题出在 pal3 和 pal4 参数未被识别的某个地方。有人可以解释为什么这些论点被忽略了吗？还是我遗漏了另一个问题？
这是我的代码：
#Read in dataset
who_data <- read.csv("https://covid19.who.int/WHO-COVID-19-global-data.csv")
pops <- read.csv("https://gist.githubusercontent.com/curran/0ac4077c7fc6390f5dd33bf5c06cb5ff/raw/605c54080c7a93a417a3cea93fd52e7550e76500/UN_Population_2019.csv")
download.file("http://thematicmapping.org/downloads/TM_WORLD_BORDERS_SIMPL-0.3.zip", destfile="world_shape_file.zip")
unzip("world_shape_file.zip")
world_spdf=sf::st_read(dsn = getwd(),layer = "TM_WORLD_BORDERS_SIMPL-0.3")
#-----Preprocessing Data-----#
who_data$Date <- as.Date(who_data$Date_reported)
cols=colnames(pops)
pop_data=pops[,c(cols[1],cols[length(cols)])]
colnames(pop_data)=c("Country","Population")
pop_data$Population=pop_data$Population*1000
pop_data[order(pop_data$Country),]
covid19_data=merge(x=who_data,y=pop_data,by="Country",all.x=TRUE)
#Adjust for population
covid19_data$Adjusted_NewCases=(covid19_data$New_cases/covid19_data$Population)*100000
covid19_data$Adjusted_NewDeaths=(covid19_data$New_deaths/covid19_data$Population)*100000
covid19_data$Adjusted_CumulCases=(covid19_data$Cumulative_cases/covid19_data$Population)*100000
covid19_data$Adjusted_CumulDeaths=(covid19_data$Cumulative_deaths/covid19_data$Population)*100000
#----- Load libraries -----#
library(shiny)
library(shinydashboard)
library(leaflet)
library(rgdal)
library(sp)
library(raster)
library(RColorBrewer)
library(maps)
library(shinyWidgets)
# Define UI for application
ui <- fluidPage(
dashboardPage(
dashboardHeader(title="COVID19 Analysis"),[enter image description here][1]
dashboardSidebar(
sidebarMenu(
menuItem("Spread",
tabName="map_spread",
icon=icon("virus")
))
),
dashboardBody(
tabItems(
tabItem(
tabName = "map_spread",
fluidRow(align="center",splitLayout(cellWidths = c("50%","25%","25%"),
sliderInput("date_filter", "Choose a date:",
min = min(covid19_data$Date), max = max(covid19_data$Date), value = min(covid19_data$Date)
),
prettyRadioButtons(inputId = "rb",
label = "Choose a metric:",
c("Cumulative Cases"="Cumulative Cases",
"Cumulative Deaths"="Cumulative Deaths"),
animation = "pulse"),
prettyRadioButtons(inputId = "rb1",
label = "Adjust for Population:",
c("No"="No",
"Yes"="Yes"),
animation="pulse")
)),
leafletOutput("world_map")
)))))
# Define server logic
server <- function(input, output) {
#---------- WORLD MAP ----------#
map_filter=reactive({
filter=subset(covid19_data,Date==input$date_filter)
return(filter)
})
merge_filter=reactive({
names(world_spdf)[names(world_spdf) == "NAME"] <- "Country"
map_data=merge(x=world_spdf,y=map_filter(),by="Country",all.x=TRUE)
})
#----Map: Choropleth Map----#
output$world_map=renderLeaflet({
bins=c(0,500,1000,5000,10000,100000,500000,1000000,5000000,Inf)
pal=colorBin(palette = "YlOrBr",domain = merge_filter()$Cumulative_cases,na.color = "transparent",bins=bins)
customLabel = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Cases: "),formatC(merge_filter()$Cumulative_cases,format="d",
big.mark=","), serp="") %>%
lapply(htmltools::HTML)
pal2=colorBin(palette = "YlOrBr",domain = merge_filter()$Cumulative_deaths,na.color = "transparent",bins=bins)
customLabel2 = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Deaths: "),formatC(merge_filter()$Cumulative_deaths,format="d",big.mark=","), serp="") %>%
lapply(htmltools::HTML)
bins2=c(0,25,50,100,250,500,1000,2500,5000,Inf)
pal3=colorBin(palette = "YlOrBr",domain = merge_filter()$Adjusted_CumulCases,na.color = "transparent",bins=bins2)
customLabel3 = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Cases per 100,000 people: "),formatC(merge_filter()$Adjusted_CumulCases,format="d",big.mark=","), serp="") %>%
lapply(htmltools::HTML)
pal4=colorBin(palette = "YlOrBr",domain = merge_filter()$Adjusted_CumulDeaths,na.color = "transparent",bins=bins2)
customLabel4 = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Deaths per 100,000 people: "),formatC(merge_filter()$Adjusted_CumulDeaths,format="d",big.mark=","), serp="") %>%
lapply(htmltools::HTML)
switch(input$rb1,
"No"=
switch(input$rb,
"Cumulative Cases"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Cumulative_cases),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal,values = ~Cumulative_cases,position = "bottomright",title = "Cumulative Cases"
),
"Cumulative Deaths"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Cumulative_deaths),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel2,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal2,values = ~Cumulative_deaths,position = "bottomright",title = "Cumulative Deaths"
)),
"Yes"=
switch(input$rb,
"Cumulative Cases"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Adjusted_CumulCases),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel3,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal3,values = ~Adjusted_CumulCases,position = "bottomright",title = "Cumulative Cases"
),
"Cumulative Deaths"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Adjusted_CumulDeaths),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel4,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal4,values = ~Adjusted_CumulDeaths,position = "bottomright",title = "Cumulative Deaths"
)))
})
}
# Run the application
shinyApp(ui = ui, server = server)
正如您在第二张图片中看到的，巴西的颜色应该是深橙色。
您必须提供您使用 colorBin 创建的调色板（或更准确地说，执行映射的函数），不仅作为图例的输入，而且还作为 addPolygons 来电。
尝试
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal2(Cumulative_deaths),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel2,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal2,values = ~Cumulative_deaths,position = "bottomright",title = "Cumulative Deaths"
))
等（pal3 和 pal4 相同）。请注意，在 fillColor 中，我使用与 addLegend.
中相同的调色板函数
我发布了一个类似的问题，但我的示例不够精简，因此我尝试减少一些。那么问题来了：
我正在从事一个 COVID19 项目，以可视化病毒在世界范围内的传播。我有一张世界等值线图，它使用日期滑块根据国家/地区的病例数和死亡人数更新地图。我有一个按钮可以通过按人口调整指标来更新地图。
我根据数据是否针对人口进行了调整，为地图创建了两组 color/bin/palette 控件。未调整数据时，地图上的颜色似乎与 bin 颜色类别适当相关，但当我针对人口进行调整时，颜色似乎不会随新的 bin 颜色类别更新。它们似乎与第一个 bin 颜色类别相关。
例如，当我想查看针对人口调整后的累计病例和累计死亡人数时，数字要小得多，但新的调色板仍然与原始调色板相关联（对于未调整的指标），所以看起来没有 data/extremely 低计数。
//忽略地图中缺失的国家//
我认为问题出在 pal3 和 pal4 参数未被识别的某个地方。有人可以解释为什么这些论点被忽略了吗？还是我遗漏了另一个问题？
这是我的代码：
#Read in dataset
who_data <- read.csv("https://covid19.who.int/WHO-COVID-19-global-data.csv")
pops <- read.csv("https://gist.githubusercontent.com/curran/0ac4077c7fc6390f5dd33bf5c06cb5ff/raw/605c54080c7a93a417a3cea93fd52e7550e76500/UN_Population_2019.csv")
download.file("http://thematicmapping.org/downloads/TM_WORLD_BORDERS_SIMPL-0.3.zip", destfile="world_shape_file.zip")
unzip("world_shape_file.zip")
world_spdf=sf::st_read(dsn = getwd(),layer = "TM_WORLD_BORDERS_SIMPL-0.3")
#-----Preprocessing Data-----#
who_data$Date <- as.Date(who_data$Date_reported)
cols=colnames(pops)
pop_data=pops[,c(cols[1],cols[length(cols)])]
colnames(pop_data)=c("Country","Population")
pop_data$Population=pop_data$Population*1000
pop_data[order(pop_data$Country),]
covid19_data=merge(x=who_data,y=pop_data,by="Country",all.x=TRUE)
#Adjust for population
covid19_data$Adjusted_NewCases=(covid19_data$New_cases/covid19_data$Population)*100000
covid19_data$Adjusted_NewDeaths=(covid19_data$New_deaths/covid19_data$Population)*100000
covid19_data$Adjusted_CumulCases=(covid19_data$Cumulative_cases/covid19_data$Population)*100000
covid19_data$Adjusted_CumulDeaths=(covid19_data$Cumulative_deaths/covid19_data$Population)*100000
#----- Load libraries -----#
library(shiny)
library(shinydashboard)
library(leaflet)
library(rgdal)
library(sp)
library(raster)
library(RColorBrewer)
library(maps)
library(shinyWidgets)
# Define UI for application
ui <- fluidPage(
dashboardPage(
dashboardHeader(title="COVID19 Analysis"),[enter image description here][1]
dashboardSidebar(
sidebarMenu(
menuItem("Spread",
tabName="map_spread",
icon=icon("virus")
))
),
dashboardBody(
tabItems(
tabItem(
tabName = "map_spread",
fluidRow(align="center",splitLayout(cellWidths = c("50%","25%","25%"),
sliderInput("date_filter", "Choose a date:",
min = min(covid19_data$Date), max = max(covid19_data$Date), value = min(covid19_data$Date)
),
prettyRadioButtons(inputId = "rb",
label = "Choose a metric:",
c("Cumulative Cases"="Cumulative Cases",
"Cumulative Deaths"="Cumulative Deaths"),
animation = "pulse"),
prettyRadioButtons(inputId = "rb1",
label = "Adjust for Population:",
c("No"="No",
"Yes"="Yes"),
animation="pulse")
)),
leafletOutput("world_map")
)))))
# Define server logic
server <- function(input, output) {
#---------- WORLD MAP ----------#
map_filter=reactive({
filter=subset(covid19_data,Date==input$date_filter)
return(filter)
})
merge_filter=reactive({
names(world_spdf)[names(world_spdf) == "NAME"] <- "Country"
map_data=merge(x=world_spdf,y=map_filter(),by="Country",all.x=TRUE)
})
#----Map: Choropleth Map----#
output$world_map=renderLeaflet({
bins=c(0,500,1000,5000,10000,100000,500000,1000000,5000000,Inf)
pal=colorBin(palette = "YlOrBr",domain = merge_filter()$Cumulative_cases,na.color = "transparent",bins=bins)
customLabel = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Cases: "),formatC(merge_filter()$Cumulative_cases,format="d",
big.mark=","), serp="") %>%
lapply(htmltools::HTML)
pal2=colorBin(palette = "YlOrBr",domain = merge_filter()$Cumulative_deaths,na.color = "transparent",bins=bins)
customLabel2 = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Deaths: "),formatC(merge_filter()$Cumulative_deaths,format="d",big.mark=","), serp="") %>%
lapply(htmltools::HTML)
bins2=c(0,25,50,100,250,500,1000,2500,5000,Inf)
pal3=colorBin(palette = "YlOrBr",domain = merge_filter()$Adjusted_CumulCases,na.color = "transparent",bins=bins2)
customLabel3 = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Cases per 100,000 people: "),formatC(merge_filter()$Adjusted_CumulCases,format="d",big.mark=","), serp="") %>%
lapply(htmltools::HTML)
pal4=colorBin(palette = "YlOrBr",domain = merge_filter()$Adjusted_CumulDeaths,na.color = "transparent",bins=bins2)
customLabel4 = paste(strong("Country: "),merge_filter()$Country,"<br/>",
strong("Cumulative Deaths per 100,000 people: "),formatC(merge_filter()$Adjusted_CumulDeaths,format="d",big.mark=","), serp="") %>%
lapply(htmltools::HTML)
switch(input$rb1,
"No"=
switch(input$rb,
"Cumulative Cases"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Cumulative_cases),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal,values = ~Cumulative_cases,position = "bottomright",title = "Cumulative Cases"
),
"Cumulative Deaths"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Cumulative_deaths),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel2,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal2,values = ~Cumulative_deaths,position = "bottomright",title = "Cumulative Deaths"
)),
"Yes"=
switch(input$rb,
"Cumulative Cases"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Adjusted_CumulCases),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel3,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal3,values = ~Adjusted_CumulCases,position = "bottomright",title = "Cumulative Cases"
),
"Cumulative Deaths"=
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal(Adjusted_CumulDeaths),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel4,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal4,values = ~Adjusted_CumulDeaths,position = "bottomright",title = "Cumulative Deaths"
)))
})
}
# Run the application
shinyApp(ui = ui, server = server)
正如您在第二张图片中看到的，巴西的颜色应该是深橙色。
您必须提供您使用 colorBin 创建的调色板（或更准确地说，执行映射的函数），不仅作为图例的输入，而且还作为 addPolygons 来电。
尝试
leaflet(merge_filter()) %>%
addProviderTiles(providers$OpenStreetMap,options=tileOptions(minZoom = 1.5,maxZoom = 8)) %>%
addPolygons(fillColor = ~pal2(Cumulative_deaths),
fillOpacity = 0.9,stroke = TRUE,color = "white",
highlight=highlightOptions(weight=5,fillOpacity = 0.3),
label=customLabel2,weight=0.3,smoothFactor = 0.2) %>%
addLegend(pal=pal2,values = ~Cumulative_deaths,position = "bottomright",title = "Cumulative Deaths"
))
等（pal3 和 pal4 相同）。请注意，在 fillColor 中，我使用与 addLegend.