Interactive Map Filter in Shiny

R
maps
Author

Brenden Smith

Published

June 26, 2024

Introduction

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!

Example Data

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.

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)

UI

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.

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")
        )
    )
)

Server

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.

Code
server <- function(input, output, session) {
      # Initialize reactive values
     rv <- reactiveValues(selected_counties = NULL,
                        filtered_data = ohio) # Initialize reactive values
}
Note

The following code chunks are wrapped within the server function call.

Outputs

This section will briefly describe the functions for our outputs: the map filter and the table.

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.

Code
  output$table <- DT::renderDT({

      rv$filtered_data |>
        sf::st_set_geometry(NULL) |>
        DT::datatable()

    })

Map

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.

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 Behavior

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.

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.

  • 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.

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
      }
    })

Conclusion

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.

Full Code

Code
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)