Can leaflet layer controls be used to alter popup contents in a Shiny dashboard?

Question

I am building a dashboard in R Shiny that includes a map rendered using R leaflet. There are popups associated with locations on the map and items in the popup are also used as layer controls. i.e., I would like to have the popup contents change with selected layers. I have searched through SO and various tutorials and blogs for a solution with no success.

A minimal synthetic example that demonstrates the behavior I hope to change:

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) 

So, for example, in the screenshot below when 'Acura' is deselected in the layer control I'd like for 'Acura' to be removed from the popup list of cars available at any dealership (not just Janes_Used_cars). I understand that the method shown for generating the popup list in the example is flawed but I think I need to find a way to access the layer control as a reactive to filter the data and update the list...

Answer 1

FWIW, here's the solution to the question I had posed (along with some minor edits to the original code).

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) 

Screenshots of the behavior I wanted and now get:

Hovering over a dealership shows all car makes available:

...and after de-selecting some car makes, they are removed from the list. Here, Acura and GM are deselected and no longer appear in the listing for any dealership: