[This article was first published on Brenden Smith, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't. IntroductionRecently, I participated in Posit’s 2024 Table Contest. For my submission, which you can view here, I included a leaflet map that acts as a filter in Shiny. This is a cool, dashboard-like feature similar to what you might find in Power BI. I recreated this effect and learned a bit through the process.
I first saw this wonderful blog post by Nathan Day but realized didn’t exactly match the feel I was going for. I adapted his code and added my own preferences (specifically allowing the input map to select multiple polygons and resetting the output table when polygons were “unclicked”). I wanted to share a basic example for others who might want to try this out!
Example DataThe data I will be using for this example can be queried using the CDCPLACES package (see more on GitHub). I will take a sample of county data from the State of Ohio. Here I am filtering only the age-adjusted rates and the measure “ACCESS2” which is the percentage of the population aged 18-64 that lack health insurance. I will also set the CRS for the data using sf::st_transform to avoid warnings when the data is queried.
Code
library(leaflet)library(shiny)library(CDCPLACES)library(dplyr)ohio <- get\_places(state = "OH", measure = "ACCESS2", geometry = TRUE) |> filter(datavaluetypeid == "AgeAdjPrv") |> select(year, stateabbr, locationname, measure, data\_value, geometry) |> sf::st\_transform(crs = 4326)
UINext, we can get into the UI side of our demo app. This is fairly straightforward. We initiate a fluid page, a title, and a sidebar layout. The sidebar has our leaflet map as a filter. In the main panel, we will output a data table.
I have added a tags$head function to add some custom CSS to the app. This is an optional step, but these two options make the panel transparent, which I think adds a lot to the look and feel of the app.
Code
ui <- fluidPage( tags$head( tags$style(HTML(".leaflet-container { background: none; } .well { background: none;}")) ), titlePanel("My Demo App"), sidebarLayout( sidebarPanel( leafletOutput("mapfilter", height = 250) ), mainPanel( DT::DTOutput("table") ) ))
ServerNow we can specify the logic of the server to get the result we want. To start we can initialize a few reactive values. This will allow us to update our filtered data and what is displayed on the map. selected_counties will correspond to what is highlighted on the map when we click, filtered_data will be the data frame that is displayed on the main table output.
Code
server <- function(input, output, session) { # Initialize reactive values rv <- reactiveValues(selected\_counties = NULL, filtered\_data = ohio) # Initialize reactive values}
NoteThe following code chunks are wrapped within the server function call.
OutputsThis section will briefly describe the functions for our outputs: the map filter and the table.
TableThis chunk defines the output corresponding to the id table, and renders a datatable. We input the reactive value of our filtered data with rv$filtered_data, remove the geometry with sf::st_set_geometry(NULL), and send it to DT::datatable() for a simple table display.
Code
output$table <- DT::renderDT({ rv$filtered\_data |> sf::st\_set\_geometry(NULL) |> DT::datatable() })
MapFor our map, we follow similar steps. We use the base data frame ohio to create our map. Future steps will show how we update this with our click behavior. highlightOptions here defines how the map reacts to hovering over polygons. It will fill the county the mouse is hovering over.
Code
output$mapfilter <- renderLeaflet({ # rendering the filter map leaflet(ohio, # initializing the map options = leafletOptions( zoomControl = FALSE, dragging = FALSE, minZoom = 6, maxZoom = 6 )) |> # then add polygons addPolygons(layerId = ~locationname, label = ~locationname, col = "black", fillColor = "steelblue", weight = 2, fillOpacity = .1, highlight = highlightOptions( fillOpacity = 1, bringToFront = TRUE )) })
Click BehaviorNext, we will define our behavior when the map is clicked. We can break this into two parts, updating the data that is fed into the output table, and changing the display of the input map.
The code chunk below runs when a polygon on our map is clicked. That is the logic of the observeEvent function and its argument input$mapfilter_shape_click. Because our actions all relate to this event, we can wrap all of our code in it. The other step here is to store the input in an object called click.
Code
observeEvent(input$mapfilter\_shape\_click, { # this is the logic behind the "click" of the map. click <- input$mapfilter\_shape\_click })
If we were to simply print(click) we would see the following output upon an initial click and a second click of the same polygon:
This will inform how we use the input to update our data and map.
We can use a set of if and else statements to store data from click in our reactive values.
click$id exists in rv$selected_counties. If it does, it will remove it from the vector.click$id is equal to “selected”. Recall that this occurs when the same polygon is selected twice in a row. If this condition is met, we will filter rv$selected_counties by removing the last value in the length of the vector.click$id is added to rv$selected_counties.Code
if (click$id %in% rv$selected\_counties) { # If selected, remove it rv$selected\_counties <- rv$selected\_counties[rv$selected\_counties != click$id] } else if(click$id == "selected"){ # when a county is clicked again it is removed rv$selected\_counties <- rv$selected\_counties[rv$selected\_counties != tail(rv$selected\_counties, n = 1)] }else { # If not selected, add it rv$selected\_counties <- c(rv$selected\_counties, click$id) }
Then we have an update to our map. We can accomplish this with leafletProxy. We will simply add an ifelse function to the argument fillOpacity. This ensures that counties present in our rv$selected_counties will have the proper fill.
Code
leafletProxy("mapfilter", session) |> addPolygons(data = ohio, layerId = ~locationname, label = ~locationname, fillColor = "steelblue", col = "black", weight = 2, fillOpacity = ifelse( ohio$locationname %in% rv$selected\_counties, 1, 0.1 ), highlight = highlightOptions( fillOpacity = 1, bringToFront = TRUE) )
Each of these pieces all fit into our observeEvent function for a click on the map, so in our consolidated code it will look like this:
Code
observeEvent(input$mapfilter\_shape\_click, { click <- input$mapfilter\_shape\_click if (click$id %in% rv$selected\_counties) { rv$selected\_counties <- rv$selected\_counties[rv$selected\_counties != click$id] } else if(click$id == "selected"){ rv$selected\_counties <- rv$selected\_counties[rv$selected\_counties != tail(rv$selected\_counties, n = 1)] }else { rv$selected\_counties <- c(rv$selected\_counties, click$id) } leafletProxy("mapfilter", session) |> addPolygons(data = ohio, layerId = ~locationname, label = ~locationname, fillColor = "steelblue", col = "black", weight = 2, fillOpacity = ifelse( ohio$locationname %in% rv$selected\_counties, 1, 0.1 ), highlight = highlightOptions( fillOpacity = 1, bringToFront = TRUE) ) })
Lastly, we have one more if else statement in our server. The following code chunk takes the reactive value rv$selected_counties and updates rv$filtered_data which we use to render the table. This logic will cause the data to reset when we have no selected counties (all the shapes are “unclicked”).
Code
observe({ # Update table filtering based on selected counties if (!is.null(rv$selected\_counties) && length(rv$selected\_counties) > 0) { # Check if any counties are selected rv$filtered\_data <- ohio |> filter(locationname %in% rv$selected\_counties) } else { rv$filtered\_data <- ohio } })
ConclusionThis post was an excellent way for me to revisit my code and share an interesting and unique Shiny feature. In this process I ended up eliminating quite a few redundancies in my original code and reinforced some of the concepts of reactivity showcased here.
I hope you find this tutorial useful. If you put it to use, please share it with me! I would love to see the work you come up with.
See the full consolidated example code below.
Full CodeCode
library(leaflet)library(shiny)library(tigris)library(CDCPLACES)library(dplyr)library(htmltools)ohio <- get\_places(state = "OH", measure = "ACCESS2", geometry = TRUE) |> filter(datavaluetypeid == "AgeAdjPrv") |> select(year, stateabbr, locationname, measure, data\_value, geometry) |> sf::st\_transform(crs = 4326)ui <- fluidPage( tags$head( tags$style(HTML(".leaflet-container { background: none; } .well { background: none;}")) ), # Application title titlePanel("My Demo App"), # Sidebar with a slider input for number of bins sidebarLayout( sidebarPanel( leafletOutput("mapfilter", height = 250) ), # Show a plot of the generated distribution mainPanel( DT::DTOutput("table") ) ))# Define server logic required to draw a histogramserver <- function(input, output, session) { rv <- reactiveValues(selected\_counties = NULL, filtered\_data = ohio) # Initialize reactive value for selected counties observeEvent(input$mapfilter\_shape\_click, { # this is the logic behind the "click" of the map. click <- input$mapfilter\_shape\_click ########## map behavior ################ # If a county is clicked if (click$id %in% rv$selected\_counties) { # If selected, remove it rv$selected\_counties <- rv$selected\_counties[rv$selected\_counties != click$id] } else if(click$id == "selected"){ # when a county is clicked again it is removed rv$selected\_counties <- rv$selected\_counties[rv$selected\_counties != tail(rv$selected\_counties, n = 1)] }else { # If not selected, add it rv$selected\_counties <- c(rv$selected\_counties, click$id) } leafletProxy("mapfilter", session) |> addPolygons(data = ohio, layerId = ~locationname, label = ~locationname, fillColor = "steelblue", # Change fill color based on selection col = "black", weight = 2, fillOpacity = ifelse(ohio$locationname %in% rv$selected\_counties, 1, 0.1), highlight = highlightOptions( fillOpacity = 1, bringToFront = TRUE) ) }) output$mapfilter <- renderLeaflet({ # rendering the filter map leaflet(ohio, options = leafletOptions( # initializing the map zoomControl = FALSE, dragging = FALSE, minZoom = 6, maxZoom = 6 )) %>% addPolygons(layerId = ~locationname, label = ~locationname, # fillColor = "black", col = "black", fillColor = "steelblue", weight = 2, fillOpacity = .1, highlight = highlightOptions( fillOpacity = 1, bringToFront = TRUE )) }) output$table <- DT::renderDT({ rv$filtered\_data |> sf::st\_set\_geometry(NULL) |> DT::datatable() }) observe({ # Update table filtering based on selected counties if (!is.null(rv$selected\_counties) & length(rv$selected\_counties) > 0) { # Check if any counties are selected rv$filtered\_data <- ohio |> filter(locationname %in% rv$selected\_counties) } else { rv$filtered\_data <- ohio } })}# Run the applicationshinyApp(ui = ui, server = server)
To leave a comment for the author, please follow the link and comment on their blog: Brenden Smith.
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.Continue reading: Interactive Map Filter in Shiny