Question

我在R中有一个功能，用于创建人口统计信息地图。

map

这是一个纯函数，它从Leaflet获取input数据，从用户获取data，从shapefile获取selectInput()来创建地图图层。 shapefile的列包括人口密度，总人口等信息，我想根据列名填充多边形。但是，我有点迷失的是弄清楚如何将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)正确地传递给Leaflet。

这是一个非常基本的例子：

totalDens

我有点迷失的是如何从下拉列表中传递用户输入totalDens的{{1}}列中的向量值（或者，传递他们选择映射到的任何一列数据））传单。换句话说，如果用户改为选择totalPop，我如何告诉Leaflet将调色板重新应用于这组新数据并重新渲染多边形？我尝试使用reactive获取input$population的结果，但无济于事。

我可以排除任何建议或方法吗？谢谢！

Answer 1

使用您在github上发布的数据我重新编写了它。中心问题似乎是调色板的产生。这非常脆弱，因为它假设您为切割选择了一个好的值。

它需要一个尝试各种方法的函数，详细信息请参见代码真正具有挑战性的案例（我发现）是1890年的亚洲人口，这是非常倾斜但确实有价值，而中位数方法总是映射一切一种颜色。

进行了以下更改：

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

以下是代码：

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)

这是输出：

1890年亚洲人口分布的一个具有挑战性的案例 - 非常高度偏斜的数据，人口集中在三个县。这意味着getpal函数将被迫放弃colorQuantile并返回colorBin以显示任何内容：

根据用户输入选择fillColor

1 个答案: