能否在Shiny仪表盘中通过Leaflet图层控件修改弹窗内容？

我正在用R Shiny构建包含Leaflet地图的仪表盘，地图点位关联弹窗，弹窗内的车辆品牌项同时用作图层控件。期望实现：当在图层控件中取消选中某个品牌（比如'Acura'）时，所有经销商弹窗列表中的该品牌条目都被移除，而非仅隐藏对应品牌的点位。现有代码生成弹窗的方式存在缺陷，需要将图层控件的选中状态作为响应式对象，以此过滤数据并动态更新弹窗内容。

最小可复现代码 #

library(tidyverse)
library(shiny)
library(leaflet)

car_dealers <- c('Bills_Used_Cars', 'Teds_Used_Cars', 'Janes_Used_cars', 
                 'Karens_Used_Cars',
                 'M1', 'M2', 'M3',
                 'C1', 'C2', 'C3')

inventory <- data.frame(
  dealership = rep(car_dealers, times = c(4, 5, 6, 4, 1, 1, 1, 1, 1, 1)),
  make = c('Acura', 'Honda', 'Toyota', 'GM',
           'Honda', 'Hyundai', 'Kia', 'Toyota', 'GM',
           'Acura', 'Honda', 'Hyundai', 'Lexus', 'Toyota', 'GM',
           'AMC', 'Buick', "Jeep", 'Land Rover', 
           rep('Audi', 6))
)

cities = c('Nashville', 'Memphis', 'Chattanooga')

coordinates <- data.frame(
  dealership = car_dealers,
  city = rep(cities, times = c(4, 3, 3)),
  long = c(-86.76, -86.8, -86.82, -86.77, 
           -90.04, -90.04, -90.04, 
           -85.31, -85.31, -85.31),
  lat = c(36.13, 36.12, 36.17, 36.19, 
          35.15, 35.15, 35.15,
          35.05, 35.05, 35.05)
)

car_locater <- left_join(x = inventory, y = coordinates, by = 'dealership') %>% 
  group_by(dealership) %>% 
  mutate(
    make_label = paste0('<b>', make, 
                        '</b>',
                          '<br>',
                          collapse = "")
  ) %>% 
  ungroup(.)

###

ui <- fluidPage(
  
  sidebarLayout(
    sidebarPanel(
      
      # Input: choose city
      selectInput(
        inputId = "cityInput",
        label = "Select a city:",
        choices = c('Memphis', 'Nashville', 'Chattanooga'),
        selected = ('Nashville')),
      width = 2
    ),
  
  mainPanel(
    h4(div("Find cars at dealerships in different cities")),
    
    leafletOutput("city_map")
  )
))

server <- function(input, output, session) {

  city_data <- reactive({ filter(car_locater, city %in% input$cityInput) })
    
  output$city_map <- renderLeaflet({

    leaflet(data = city_data()) %>%
    addProviderTiles(providers$CartoDB.VoyagerLabelsUnder,
                     options = providerTileOptions(noWrap = TRUE)) %>%

    addCircleMarkers(
      lng = city_data()$long,
      lat = city_data()$lat,
      color = 'black',
      stroke = TRUE,
      weight = 1,
      radius = 7.5,
      label = city_data()$dealership,
      labelOptions = labelOptions(noHide = T, textsize = "15px",
                                  direction = "bottom"),
      popup = city_data()$make_label,
      popupOptions = popupOptions(maxWidth = 1800, noHide = F,
                                  direction = 'auto'),
      group = city_data()$make
    ) %>%

    addLayersControl(
      position = 'topright',
      overlayGroups = sort(city_data()$make),
      options = layersControlOptions(collapsed = FALSE)
    )
  })
  
}
 
shinyApp(ui = ui, server = server) 

解决方案 #

核心思路是监听Leaflet图层控件的选中状态，将其作为响应式输入过滤数据，再通过leafletProxy动态更新弹窗内容，避免重复渲染整个地图。

修改后的完整代码 #

library(tidyverse)
library(shiny)
library(leaflet)

car_dealers <- c('Bills_Used_Cars', 'Teds_Used_Cars', 'Janes_Used_cars', 
                 'Karens_Used_Cars',
                 'M1', 'M2', 'M3',
                 'C1', 'C2', 'C3')

inventory <- data.frame(
  dealership = rep(car_dealers, times = c(4, 5, 6, 4, 1, 1, 1, 1, 1, 1)),
  make = c('Acura', 'Honda', 'Toyota', 'GM',
           'Honda', 'Hyundai', 'Kia', 'Toyota', 'GM',
           'Acura', 'Honda', 'Hyundai', 'Lexus', 'Toyota', 'GM',
           'AMC', 'Buick', "Jeep", 'Land Rover', 
           rep('Audi', 6))
)

cities = c('Nashville', 'Memphis', 'Chattanooga')

coordinates <- data.frame(
  dealership = car_dealers,
  city = rep(cities, times = c(4, 3, 3)),
  long = c(-86.76, -86.8, -86.82, -86.77, 
           -90.04, -90.04, -90.04, 
           -85.31, -85.31, -85.31),
  lat = c(36.13, 36.12, 36.17, 36.19, 
          35.15, 35.15, 35.15,
          35.05, 35.05, 35.05)
)

car_locater <- left_join(x = inventory, y = coordinates, by = 'dealership') %>% 
  ungroup(.)

###

ui <- fluidPage(
  
  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "cityInput",
        label = "Select a city:",
        choices = c('Memphis', 'Nashville', 'Chattanooga'),
        selected = 'Nashville'),
      width = 2
    ),
  
  mainPanel(
    h4("Find cars at dealerships in different cities"),
    leafletOutput("city_map")
  )
))

server <- function(input, output, session) {

  # 基础城市过滤数据
  city_data <- reactive({ 
    filter(car_locater, city %in% input$cityInput) 
  })
  
  # 获取所有可用品牌（用于图层控件初始化）
  available_makes <- reactive({
    sort(unique(city_data()$make))
  })
  
  # 监听图层控件选中状态，默认选中所有品牌
  selected_makes <- reactive({
    input$city_map_groups %||% available_makes()
  })
  
  # 结合城市和选中品牌过滤数据
  filtered_data <- reactive({
    city_data() %>% filter(make %in% selected_makes())
  })
  
  # 生成响应式弹窗标签：按经销商分组，拼接选中品牌的HTML
  popup_labels <- reactive({
    filtered_data() %>%
      group_by(dealership) %>%
      summarise(
        make_label = paste0('<b>', make, '</b><br>', collapse = ""),
        long = first(long),
        lat = first(lat)
      ) %>%
      ungroup()
  })
  
  # 初始化地图
  output$city_map <- renderLeaflet({
    leaflet(data = city_data()) %>%
      addProviderTiles(providers$CartoDB.VoyagerLabelsUnder,
                       options = providerTileOptions(noWrap = TRUE)) %>%
      addCircleMarkers(
        lng = ~long,
        lat = ~lat,
        color = 'black',
        stroke = TRUE,
        weight = 1,
        radius = 7.5,
        label = ~dealership,
        labelOptions = labelOptions(noHide = TRUE, textsize = "15px", direction = "bottom"),
        group = ~make
      ) %>%
      addLayersControl(
        position = 'topright',
        overlayGroups = available_makes(),
        options = layersControlOptions(collapsed = FALSE)
      )
  })
  
  # 监听图层变化，更新弹窗
  observeEvent(selected_makes(), {
    proxy <- leafletProxy("city_map", data = popup_labels())
    
    # 先清除现有弹窗，再添加新的
    proxy %>% clearPopups() %>%
      addPopups(
        lng = ~long,
        lat = ~lat,
        popup = ~make_label,
        popupOptions = popupOptions(maxWidth = 1800, direction = 'auto')
      )
  })
  
}
 
shinyApp(ui = ui, server = server)

关键修改说明 #

• 监听图层选中状态：利用Leaflet自动生成的input$city_map_groups（当前选中的图层组向量），用%||%处理初始化时的空值，默认选中所有品牌。
• 响应式数据过滤：filtered_data结合城市选择和选中的品牌，动态过滤原始数据。
• 动态生成弹窗内容：popup_labels按经销商分组，只保留选中品牌的条目，重新拼接HTML弹窗。
• 用leafletProxy更新：通过leafletProxy仅更新弹窗部分，无需重新渲染整个地图，提升性能。

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