Shiny应用中基于Leaflet地图点击实现数据子集化问题

问题根源 #

• 错误使用地图通用点击事件input$map_click，该事件仅能获取地图任意点坐标，无法识别点击的多边形（县）；应使用多边形专属点击事件input$map_shape_click。
• addPolygons未配置layerId参数，导致点击多边形时无法返回对应的县名标识，无法匹配数据框中的Geography字段。
• 标签文本错误引用temp$County，GADM美国县级数据中，县名字段为NAME_2，而非County，会导致标签显示异常。

修改后的完整代码 #

library(shiny)
library(leaflet)
library(sp)
library(rgdal)
library(raster) # getData函数归属raster包，需加载

# 示例数据框
df <- data.frame(
  Indicator = c("primary", "primary", "primary", "primary", "primary", "primary"),
  Geography = c("Ventura", "Orange", "Alameda", "Alpine", "Amador", "Butte"),
  Year = c(2008, 2008, 2008, 2008, 2008, 2008),
  Category = c("Total Population", "Total Population", "Total Population", "Total Population", "Total Population", "Total Population"),
  Subcategory = c("Total population", "Total population", "Total population", "Total population", "Total population", "Total population"),
  Numerator = c(NA, 2618, 124, 0, 0, 13),
  Denominator = c(NA, 532102, 20483, 11, 295, 2466),
  Rate = c(60.3, 49.2, 60.5, 0.0, 0.0, 52.7),
  stringsAsFactors = FALSE
)

# 加载美国县级多边形数据
USA <- getData("GADM", country = "usa", level = 2)

ui <- fluidPage(
  titlePanel("County Rate Map"),
  leafletOutput("map"),
  dataTableOutput("dt")
)

server <- function(input, output, session) {
  
  # 合并多边形数据与df
  merged_data <- sp::merge(USA, df, duplicateGeoms = TRUE, by.x = "NAME_2", by.y = "Geography")
  
  # 渲染地图
  output$map <- renderLeaflet({
    temp <- sp::merge(USA, df, duplicateGeoms = TRUE, by.x = "NAME_2", by.y = "Geography")
    
    max_value <- max(temp$Rate, na.rm = TRUE)
    max_rounded <- ceiling(max_value / 9) 
    bins <- c(seq(0, max_value, by = max_rounded), max_value)
    pal <- colorBin("Blues", domain = as.numeric(temp$Rate), bins = bins)
    
    leaflet(temp) %>%
      setView(lng = -118.2437, lat = 34.0522, zoom = 7) %>%
      addProviderTiles("CartoDB.Positron") %>%
      addPolygons(
        fillColor = ~pal(Rate),
        weight = 2,
        opacity = 1,
        color = "white",
        dashArray = "3",
        fillOpacity = 0.7,
        highlightOptions = highlightOptions(
          weight = 5,
          color = "#666",
          dashArray = "",
          fillOpacity = 0.7,
          bringToFront = TRUE),
        # 为每个多边形绑定县名ID，用于点击事件识别
        layerId = ~NAME_2,
        label = lapply(
          paste0(
            "County: ", temp$NAME_2, "<br>",
            "Rate: ", temp$Rate, "<br>",
            "Denominator: ", temp$Denominator,"<br>",
            "Numerator:", temp$Numerator
          ),
          HTML
        ),
        labelOptions = labelOptions(
          style = list("font-weight" = "normal"
                       , padding = "3px 8px"
                       , textsize = "15px"
                       , direction = "auto" ))
      ) %>%
      addLegend(title = "Measure Rate Map",pal = pal, values = ~Rate, opacity = 0.7,
                position = "bottomright")
  })
  
  # 根据点击的县筛选数据
  selected_county_data <- reactive({
    # 使用多边形点击事件获取选中的县
    click_county <- input$map_shape_click
    if (is.null(click_county)) {
      return(NULL)
    } else {
      clicked_county <- click_county$id
      subset(df, Geography == clicked_county)
    }
  })
  
  output$dt <- renderDataTable({
    selected_county_data()
  })
}

shinyApp(ui, server)

关键修改说明 #

• 替换点击事件：改用input$map_shape_click捕获多边形点击，确保能获取选中县的标识。
• 添加layerId绑定：通过layerId = ~NAME_2将每个多边形与县名关联，点击时可直接通过click_county$id拿到匹配df$Geography的县名。
• 修正标签字段：将temp$County改为temp$NAME_2，保证标签显示正确的县名信息。
• 补充依赖包：添加library(raster)，解决getData函数的加载依赖问题。

内容的提问来源于stack exchange，提问作者firmo23