我在 R 中有一个函数,用于创建人口统计信息地图。
draw_demographics <- function(map, input, data) {
pal <- colorQuantile("YlGnBu", domain = NULL, n = 7)
#browser()
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(input$population),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
它是一个纯函数,它获取来自 Leaflet 的
map
数据、来自用户的 input
以及来自 shapefile 的 data
来创建地图图层。 shape文件的列包括人口密度、总人口等信息,我想根据列名称填充多边形。但我有点迷失的是弄清楚如何正确地将 selectInput()
传递给 Leaflet。
这是一个非常基本的示例:
library(shiny)
library(leaflet)
ui <- bootstrapPage(
fluidRow(
column(12, leafletOutput("map"))
),
fluidRow(
column(12, uiOutput("select_population"))
)
)
server <- function(input, output, session) {
output$select_population <- renderUI({
choices <- list("None" = "None",
"All population" = "totalPop",
"Population density" = "totalDens",
"Black population" = "totalAfAm",
"Asian population" = "totalAsian",
"Latino population" = "totalHispanic",
"Native population" = "totalIndian")
selectInput(inputId = "population", label = "Demographics",
choices = choices, selected = "totalDens")
})
output$map <- renderLeaflet({
map <- leaflet() %>%
addProviderTiles(provider = "CartoDB.Positron",
providerTileOptions(detectRetina = FALSE,
reuseTiles = TRUE,
minZoom = 4,
maxZoom = 8)) %>%
setView(lat = 43.25, lng = -94.30, zoom = 6)
map %>% draw_demographics(input, counties[["1890"]])
})
}
## Helper functions
# draw_demographics draws the choropleth
draw_demographics <- function(map, input, data) {
pal <- colorQuantile("YlGnBu", domain = NULL, n = 7)
#browser()
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(input$population),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
shinyApp(ui, server)
我有点迷失的是如何将用户从下拉列表中输入的
totalDens
中的向量值(或者,传递他们选择映射的任何数据列)传递到 Leaflet。换句话说,如果用户选择 totalDens
,我如何告诉 Leaflet 将调色板重新应用于这组新数据并重新渲染多边形?我尝试使用 totalPop
来获取 reactive
的结果,但没有成功。您有什么建议或可以解决问题的方法吗?
它需要一个尝试各种方法的函数,请参阅代码了解详细信息真正具有挑战性的案例(我发现)是 1890 年的亚洲人口,它非常倾斜,但绝对有值,并且中值方法总是将所有内容映射到一个颜色。
进行了以下更改:
添加了一些代码来下载和保存县数据
input$population
req(input$population)
getpal
colorBin
会为所有内容着色 - 可能是一个错误。如果没有人口数据,则不会绘制县形状,因为这需要花费大量时间,而且这样的情况很多。colorQuantile
这是输出:
1890 年亚洲人口分布的挑战性案例 - 数据高度倾斜,人口集中在三个县。这意味着
library(shiny)
library(leaflet)
library(sf)
ui <- bootstrapPage(
fluidRow(
column(12, leafletOutput("map"))
),
fluidRow(
column(12, uiOutput("select_year")),
column(12, uiOutput("select_population"))
)
)
choices <- list("None" = "None",
"All population" = "totalPop",
"Population density" = "totalDens",
"Black population" = "totalAfAm",
"Asian population" = "totalAsian",
"Latino population" = "totalHispanic",
"Native population" = "totalIndian")
fn <- Sys.glob("shp/*.shp")
counties <- lapply(fn, read_sf)
names(counties) <- c("1810", "1820","1830","1840","1850","1860","1870","1880","1890","1900",
"1910","1920","1930","1940","1950","1960","1970","1980","1990","2000","2010")
server <- function(input, output, session) {
output$select_population <- renderUI({
selectInput(inputId = "population", label = "Demographics",
choices = choices, selected = "totalDens")
})
output$select_year <- renderUI({
selectInput(inputId = "year", label = "Year",
choices = names(counties))
})
output$map <- renderLeaflet({
req(input$population)
req(input$year)
map <- leaflet() %>%
addProviderTiles(provider = "CartoDB.Positron",
providerTileOptions(detectRetina = FALSE,
reuseTiles = TRUE,
minZoom = 4,
maxZoom = 8)) %>%
setView(lat = 43.25, lng = -94.30, zoom = 6)
map %>% draw_demographics(input, counties[[input$year]])
})
}
# try out various ways to get an acceptable color palette function
getpal <- function(cpop,nmax){
if (length(cpop)>1){
# try out value from nmax down to 1
for (n in nmax:1){
qpct <- 0:n/n
cpopcuts <- quantile(cpop,qpct)
# here we test to see if all the cuts are unique
if (length(unique(cpopcuts))==length(cpopcuts)){
if (n==1){
# The data is very very skewed.
# using quantiles will make everything one color in this case (bug?)
# so fall back to colorBin method
return(colorBin("YlGnBu",cpop, bins=nmax))
}
return(colorQuantile("YlGnBu", cpop, probs=qpct))
}
}
}
# if all values and methods fail make everything white
pal <- function(x) { return("white") }
}
draw_demographics <- function(map, input, data) {
cpop <- data[[input$population]]
if (length(cpop)==0) return(map) # no pop data so just return (much faster)
pal <- getpal(cpop,7)
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(cpop),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
shinyApp(ui, server)
函数将被迫放弃
getpal
并退回到 colorQuantile
以显示任何内容:
colorBin
不是
fillColor = ~pal(data[[input$column]])