根据用户输入选择填充颜色

问题描述 投票:0回答:2

我在 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
的结果,但没有成功。
您有什么建议或可以解决问题的方法吗?

r shiny r-leaflet
2个回答
3
投票

它需要一个尝试各种方法的函数,请参阅代码了解详细信息真正具有挑战性的案例(我发现)是 1890 年的亚洲人口,它非常倾斜,但绝对有值,并且中值方法总是将所有内容映射到一个颜色。

进行了以下更改:

添加了一些代码来下载和保存县数据
  • 读入您提供的数据
  • 添加了一个字段来选择年份
  • 添加了
  • input$population
  • 来阻止典型的闪亮初始化 NULL 错误。
    创建了一个 
  • req(input$population)
  • ,尝试从等空间分位数开始的不同值。
    如果分位数数量减少到 2,那么它会回落到 
  • getpal
  • ,因为在这种情况下
    colorBin
    会为所有内容着色 - 可能是一个错误。
    如果没有人口数据,则不会绘制县形状,因为这需要花费大量时间,而且这样的情况很多。
  • 这是代码:

colorQuantile

这是输出:

enter image description here 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
以显示任何内容:

enter image description here


1
投票
TLDR;

colorBin

不是
fillColor = ~pal(data[[input$column]])
    

© www.soinside.com 2019 - 2024. All rights reserved.