Recently, 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!
The 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.
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)Next, 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.
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")
)
)
)Now 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.
server <- function(input, output, session) {
# Initialize reactive values
rv <- reactiveValues(selected_counties = NULL,
filtered_data = ohio) # Initialize reactive values
}The following code chunks are wrapped within the server function call.
This section will briefly describe the functions for our outputs: the map filter and the table.
This 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.
output$table <- DT::renderDT({
rv$filtered_data |>
sf::st_set_geometry(NULL) |>
DT::datatable()
})For 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.
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
))
})Next, 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.
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.
The first statement checks to see if the current click$id exists in rv$selected_counties. If it does, it will remove it from the vector.
The next statement checks to see if the 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.
Lastly, if the other two conditions are not met, the new and unique click$id is added to rv$selected_counties.
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.
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:
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”).
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
}
})This 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.
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 histogram
server <- 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 application
shinyApp(ui = ui, server = server)