Labels in Shiny Leaflet Map with Multiple Selections

[mgaughan]

I want to create labels on a Shiny map that are based on a reactive layer that the user may select multiple features from. Right now, if a user selects more than one feature, the label returns the values for all selected features. Is there a way to incorporate the position of the mouse into the addPolygons() label functionality?

I've included a code snippet below, but you will need to download the data to reproduce.

library(shiny)
library(sf)
library(tidyverse)
library(leaflet)
library(shiny)
library(sp)
library(rsconnect)
library(shinyWidgets)
library(stplanr)
library(shinythemes)
library(mapview)
library(colorspace)

#read dataset from https://gis-kingcounty.opendata.arcgis.com/datasets/census-2000-tracts-major-wtrbdy-features-removed-tracts00-shore-area. 
#Change DSN in st_read to match your directory path. 



tracts_demo <- st_read(dsn = "//dot/Transit/SD/ServicePlanning/Major Projects/Renton_Kent_Auburn_Area_Mobility_Plan/EIR/R/data/2016tract.shp", 
                       stringsAsFactors = FALSE) %>% 
  st_transform(., crs = 4326) 

# Define UI for application that draws a histogram
ui <- fluidPage(
   
   # Application title
   titlePanel("Repex Demo"),
   
   # Sidebar with a slider input for number of bins 
   sidebarLayout(
      sidebarPanel(
          selectInput("tracts",
                      "Select  Tracts byTract_ID:",
                      choices = as.list(tracts_demo$GEOID),
                      multiple = TRUE,
                      selectize = TRUE
          )
      ),
      
      # Show a plot of the generated distribution
      mainPanel(
        leafletOutput("travelshed_map", height = "100vh")
      )
   )
)


server <- function(input, output) {
   
  tracts_reactive <-reactive({
    
  tracts_demo %>% filter( tracts_demo$GEOID %in% input$tracts)
    
  }) 
  
  popup <-  reactive({
    HTML(paste0("<b>","Tract No: ","</b>", tracts_reactive()$GEOID))
  })
  
  
  output$travelshed_map <- renderLeaflet({
    
    leaflet() %>%
      addProviderTiles("CartoDB.Positron") %>%
      setView(lng = -122.217064, lat = 47.482880, zoom = 11 )
  }) 
  
  observe({ 
    proxy<-  leafletProxy("travelshed_map") %>% clearGroup("tracts_reactive")
    
    proxy %>%
      addPolygons(data= tracts_reactive(), color = "#444444", weight = 1, smoothFactor = 0.5,
                  opacity = 1.0, fillOpacity = 0.5,
                  fillColor = "Black", group = "tracts",
                  highlightOptions = highlightOptions(color = "white", weight = 2,
                                                      bringToFront = TRUE),
                  label = popup()) 
  })
  
  
}



# Run the application 
shinyApp(ui = ui, server = server)

[barret]

Check out https://rstudio.github.io/leaflet/shiny.html#map-events .

It describes using leaflet's shiny inputs, such as a click event. For your map travelshed_map, you'd use: input$travelshed_map_click for your lat/long click information.

[mgaughan]

Thanks for the help @barret. I followed the example and it seems to mostly work. However, when I tried to pass a variable to the label, only the static text was returned. What am I doing wrong?

# function to create labels
 showTractPopUp <- function(tract, lat, lng) {
    selectedTract <- tracts_reactive()[tracts_reactive()$GEOID == tract,]
    content <-as.character(paste0(HTML("<b>","Tract No: ","</b>"), selectedTract$GEOID))
    
    leafletProxy("travelshed_map") %>% addPopups(lng, lat, content, layerId = tract)                          
  }

#observe clicks
observe({
  leafletProxy("travelshed_map") %>% clearPopups()
  event <- input$travelshed_map_shape_click
  if(is.null(event))
    return()
  
  isolate({
    showTractPopUp(event$id, event$lat, event$lng)
  })

[mgaughan]

I revised the original code to more closely reflect the code in the zipcode explorer app. Now, instead of displaying the values for all selected features, the popup displays nothing. However, the code throws no errors. How can I pass content to the label successfully?

#libraries and data source for tract layer

library(shiny)
library(sf)
library(tidyverse)
library(leaflet)
library(sp)


#read dataset from https://gis-kingcounty.opendata.arcgis.com/datasets/census-2000-tracts-major-wtrbdy-features-removed-tracts00-shore-area. 
#Change DSN in st_read to match your directory path. 


tracts_demo <- st_read(
  dsn = "//dot/Transit/SD/ServicePlanning/Major Projects/Renton_Kent_Auburn_Area_Mobility_Plan/EIR/R/data/2016tract.shp", 
                       stringsAsFactors = FALSE) %>% 
  st_transform(., crs = 4326) 

#UI
ui <- fluidPage(
  
  # Application title
  titlePanel("Repex Demo"),
  
  # Sidebar with a slider input for number of bins 
  sidebarLayout(
    sidebarPanel(
      selectInput("tracts",
                  "Select Tracts by Tract_ID:",
                  choices = as.list(tracts_demo$GEOID),
                  multiple = TRUE,
                  selectize = TRUE
      )
    ),
    

    mainPanel(
      leafletOutput("map", height = "100vh")
    )
  )
)

Server code. This is the problematic piece of the code.

server <- function(input, output) {
  
  tracts_reactive <-reactive({   
    tracts_demo %>%
   filter( tracts_demo$GEOID %in% input$tracts)
  }) 
  
  output$map <- renderLeaflet({
    
    leaflet() %>%
      addProviderTiles("CartoDB.Positron") %>%
      setView(lng = -122.217064, lat = 47.482880, zoom = 11 )
  }) 
  
  observe({ 
    proxy<-  leafletProxy("map")
    %>% clearGroup("tracts")
    
    proxy %>%
      addPolygons(data= tracts_reactive(),
     color = "#444444",
     weight = 1, 
     smoothFactor = 0.5,
     opacity = 1.0,
     fillOpacity = 0.5,
    fillColor = "Black", 
    group = "tracts")
  }) 
  
#I think this code is the issue
  showTractPopUp <- function(tracts, lat, lng) {
    selectedTract <- tracts_demo[tracts_demo$GEOID == tracts,]
    content <-as.character(selectedTract$GEOID)
    leafletProxy("map") %>% addPopups(lng, lat, content, layerId = tracts)                          
  }
  
  observe({
    leafletProxy("map") %>% clearPopups()
    event <- input$map_shape_click
    if(is.null(event))
      return()
    
    isolate({
      showTractPopUp(event$id, event$lat, event$lng)
    })
  })
}


# Run the application 
shinyApp(ui = ui, server = server)

[mgaughan]

I solved the issue myself. The basic issue was that I used an HTML() wrapper in my reactive function controlling the content in the label. I originally chose to do this because the hover labels in leaflet (generated through a addPolygons(...label = ) call) didn't have an in-built way of making the labels display well. For some reason, using addPolygons(...popup=) recognizes HTML tags and does not need a HTML() wrapper within the reactive function that controls label content.

My end solution is to use popup labels rather than hover labels and remove all HTML() wrappers in my label code.