传单图层控件可用于更改闪亮仪表板中的弹出内容吗？

Question

我正在 R Shiny 中构建一个仪表板，其中包括使用 R leaflet 渲染的地图。有与地图上的位置关联的弹出窗口，弹出窗口中的项目也用作图层控件。即，我希望弹出内容随所选图层而变化。我已经搜索过 SO 以及各种教程和博客来寻找解决方案，但没有成功。

一个最小的综合示例，展示了我希望改变的行为：

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) 

因此，例如，在下面的屏幕截图中，当在图层控件中取消选择“Acura”时，我希望将“Acura”从任何经销商（不仅仅是 Janes_Used_cars）可用的汽车弹出列表中删除。我知道示例中显示的用于生成弹出列表的方法是有缺陷的，但我认为我需要找到一种方法来访问图层控件，作为过滤数据和更新列表的反应...

Answer 1

FWIW，这是我提出的问题的解决方案（以及对原始代码的一些细微修改）。

library(tidyverse)
library(shiny)
library(htmltools)
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_locator <- left_join(x = inventory, y = coordinates, by = 'dealership')

###

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({
    
    car_locator %>%
      filter(city %in% input$cityInput) %>%
      arrange(., make)
  })
  
  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 = NA, #'black',
        stroke = FALSE,
        weight = 0,
        radius = 0,
        label = city_data()$dealership,
        labelOptions = labelOptions(noHide = T, textsize = "14px",
                                    direction = "bottom")
      ) %>%
      
      addLayersControl(
        position = 'topright',
        overlayGroups = sort(city_data()$make),
        options = layersControlOptions(collapsed = FALSE)
      )
  })
    
  observe({
    selected_makes <- req(input$city_map_groups)
    
    label_data <- car_locator %>% 
      arrange(., make) %>% 
      filter(make %in% selected_makes) %>%
      group_by(dealership) %>%
      mutate(
        make_label = paste0('<b>', make,
                            '</b>',
                            '<br>',
                            collapse = "")
      ) %>%
      ungroup(.)
    
    label_text2 <- 
      as.list(label_data$make_label)
    
    leafletProxy("city_map", 
                 data = label_data) %>%
      
      addCircleMarkers(
        lng = label_data$long,
        lat = label_data$lat,
        color = 'black',
        stroke = TRUE,
        weight = 1,
        fillColor = 'red',
        fillOpacity = 0.5,
        radius = 7.5,
        label = lapply(label_text2, HTML),
        labelOptions = labelOptions(noHide = F, textsize = "13.5px"),
        group = label_data$make
      ) 
    
  })
  
}

shinyApp(ui = ui, server = server) 

我想要的行为的屏幕截图，现在得到了：

将鼠标悬停在经销店上会显示所有可用的汽车：

...取消选择某些汽车品牌后，它们将从列表中删除。在这里，讴歌和通用汽车被取消选择，不再出现在任何经销商的列表中：