实现Leaflet地图点击与Shiny组件联动的数据集筛选与展示

需要开发一个Shiny应用，实现以下交互功能：

• 应用启动时，展示由pickerInput组件选中的所有县的地图及对应数据表格；
• 点击地图上的任意县后，表格仅展示该县数据，同时pickerInput组件自动选中该县；
• 通过pickerInput组件多选县时，地图和表格同步更新为选中县的内容。

以下是初始代码：

library(shiny)
library(leaflet)
library(sp)
library(rgdal)  # Make sure you have this package installed
library(raster)
library(shinyWidgets)
# Sample dataframe (replace this with your actual data)
df <- data.frame(
  Indicator = c("primary", "primary", "primary", "primary", "primary", "primary"),
  Geography = c("Ventura", "Orange", "Alameda", "Alpine", "Amador", "Butte"),
  State = c(rep("California",6)),
  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)
)


# Load USA polygon data
USA <- getData("GADM", country = "usa", level = 2)

ui <- fluidPage(
  titlePanel("County Rate Map"),
  pickerInput(
    inputId = "gr",
    label = "County",
    choices = unique(df$Geography),
    selected = unique(df$Geography),
    multiple = T
  ),
  
  leafletOutput("map"),
  dataTableOutput("dt")
)

server <- function(input, output, session) {
  
  # Merge the USA polygon data with the dataframe
  merged_data <- sp::merge(USA, df, duplicateGeoms = TRUE, by.x = c("NAME_1","NAME_2"), by.y = c("State","Geography"))
  dfpls<-reactive({
    df<-subset(merged_data,NAME_2%in%input$gr)
    df
  })
  
  #calls map
  output$map<-renderLeaflet({
    # Load your data for the choropleth
    #data <- read.csv("your_data.csv")  # Replace with the path to your data file
    
    # Merge the data with the US states geojson data
    #merged_data <- merge(us_states, data, by.x = "state", by.y = "State", all.x = TRUE)
    # temp <- sp::merge(USA, df, duplicateGeoms = TRUE, by.x = c("NAME_2"), by.y = c("Geography"))
    temp <- dfpls()
    
    # Determine the maximum value excluding NA values
    max_value <- max(temp$Rate, na.rm = TRUE)
    
    # Calculate the maximum value rounded up to the nearest multiple of 20
    max_rounded <- ceiling(max_value / 9) 
    
    # Create the bins vector
    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,
        layerId = temp$NAME_2,
        highlightOptions = highlightOptions(
          weight = 5,
          color = "#666",
          dashArray = "",
          fillOpacity = 0.7,
          bringToFront = TRUE),
        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")
  })
  
  # Create a reactive subset of data based on selected county
  selected_county_data <- reactive({
    # click_county <- input$map_click
    click_county <- input$map_shape_click
    
    # print(click_county)
    if (is.null(click_county)) {
      dfpls()
    } else {
      clicked_county <- click_county$id
      subset(dfpls(), NAME_2 == clicked_county)
    }
  })
  output$dt<-renderDataTable({
    selected_county_data()
  })
}

shinyApp(ui, server)

library(shiny)
library(leaflet)
library(sp)
library(rgdal)
library(raster)
library(shinyWidgets)

# 示例数据（替换为你的实际数据）
df <- data.frame(
  Indicator = c("primary", "primary", "primary", "primary", "primary", "primary"),
  Geography = c("Ventura", "Orange", "Alameda", "Alpine", "Amador", "Butte"),
  State = c(rep("California",6)),
  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)
)

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

ui <- fluidPage(
  titlePanel("县级比率地图"),
  pickerInput(
    inputId = "gr",
    label = "选择县",
    choices = unique(df$Geography),
    selected = unique(df$Geography),
    multiple = TRUE,
    options = list(`actions-box` = TRUE) # 增加全选/取消全选按钮，提升操作体验
  ),
  
  leafletOutput("map"),
  dataTableOutput("dt")
)

server <- function(input, output, session) {
  
  # 合并地理数据与业务数据
  merged_data <- sp::merge(USA, df, duplicateGeoms = TRUE, by.x = c("NAME_1","NAME_2"), by.y = c("State","Geography"))
  
  # 根据pickerInput选中项过滤数据
  filtered_data <- reactive({
    subset(merged_data, NAME_2 %in% input$gr)
  })
  
  # 渲染地图
  output$map <- renderLeaflet({
    temp <- filtered_data()
    
    # 计算颜色分箱参数
    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,
        layerId = ~NAME_2, # 使用公式语法绑定图层ID
        highlightOptions = highlightOptions(
          weight = 5,
          color = "#666",
          dashArray = "",
          fillOpacity = 0.7,
          bringToFront = TRUE),
        label = lapply(
          paste0(
            "县: ", temp$NAME_2, "<br>",
            "比率: ", temp$Rate, "<br>",
            "分母: ", temp$Denominator,"<br>",
            "分子:", temp$Numerator
          ),
          HTML
        ),
        labelOptions = labelOptions(
          style = list("font-weight" = "normal",
                       padding = "3px 8px",
                       textsize = "15px",
                       direction = "auto" ))
      ) %>%
      addLegend(title = "指标比率地图", pal = pal, values = ~Rate, opacity = 0.7,
                position = "bottomright")
  })
  
  # 监听地图点击事件，同步更新pickerInput选中项
  observeEvent(input$map_shape_click, {
    clicked_county <- input$map_shape_click$id
    updatePickerInput(session, "gr", selected = clicked_county)
  })
  
  # 渲染数据表格，仅展示业务相关列
  output$dt <- renderDataTable({
    display_cols <- c("NAME_2", "Indicator", "Year", "Category", "Subcategory", "Numerator", "Denominator", "Rate")
    filtered_data()[, display_cols]
  })
}

shinyApp(ui, server)

• 地图与pickerInput双向联动：新增observeEvent监听地图点击事件，点击县后自动更新pickerInput的选中值，满足点击地图同步选中项的需求。
• 数据表格优化：筛选展示业务相关列，避免空间数据列（如多边形坐标）出现在表格中，提升可读性。
• 交互体验提升：给pickerInput添加actions-box选项，支持全选/取消全选操作。
• 数据源统一：使用filtered_data()作为地图和表格的共同数据源，确保pickerInput多选时两者同步更新。
• 语法规范优化：使用公式语法~NAME_2绑定图层ID，符合Shiny反应式编程规范。

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