In hoga-it/leafdown: Provides Drill Down Functionality for 'leaflet' Choropleths

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

In this article, we demonstrate how to connect a leafdown map to other Shiny elements.

knitr::include_graphics("../man/figures/app_election_map.png")

Click here for the full demo app

Data

As described in the Introduction article., we need two types of data:

SpatialPolygonsDataFrames, the shapes of the US-States and Counties, taken from the raster package.
Election Results and Census Data, the data we want to display on the map, taken from the example data sets that come with the leafdown package. (The original data comes from Deleetdk. For more information about the data, please see ?us_election_states or ?us_election_counties respectively)

The Map itself

The structure of the map is pretty similar to the map from the Introduction article. Here we show the results of the US Presidential Election from 2016.

Connecting Graphs to our Map

In this section, we want to demonstrate how simple it is to connect graphs or similar UI-elements with the map.

We create two graphs that give more insight into the currently selected shapes:

As the map only shows the winner, we create a bar chart to show the percentages from every party.
Additionally, we add a graph showing the racial makeup.

The changes in the UI are straightforward:

column(
  width = 5,
  # box for racial makeup graph
  bs4Card(
    width = 12,
    closable = F,
    collapsible = F,
    title = "Racial makeup in percentages",
    echarts4rOutput("socio")
  ),
  # box for party percent graph
  bs4Card(
    width = 12,
    closable = F,
    collapsible = F,
    title = "Votes in percent",
    echarts4rOutput("party")
  )
)

To connect the graphs with the map, we can use the $curr_sel_data() attribute. This attribute is a reactiveValue which allows us to update the graphs whenever the user selects a shape on the map or drills a level up or down.

In the server, we obtain the data using df <- my_leafdown$curr_sel_data().

Creating the rest of the graph is again straightforward.

output$party <- renderEcharts4r({
  # get the currently selected data from the map
  df <- my_leafdown$curr_sel_data()

  # check whether any shape is selected, show general election-result if nothing is selected
  if (nrow(df) > 0) {
    if (my_leafdown$curr_map_level == 1) {
      df <- df[, c("state_abbr", "Democrats2016", "Republicans2016", "Libertarians2016", "Green2016")]
      df <- df %>%
        pivot_longer(2:5, "party") %>%
        group_by(party)
    } else {
      df <- df[, c("County", "Democrats2016", "Republicans2016", "Libertarians2016", "Green2016")]
      df <- df %>%
        pivot_longer(2:5, "party") %>%
        group_by(party)
      df$value <- df$value
      names(df)[1] <- "state_abbr"
    }
  } else {
    # show general election-result as no state is selected
    df <- data.frame(
      party = c("Democrats2016", "Republicans2016", "Libertarians2016", "Green2016"),
      state_abbr = "USA",
      value = c(0.153, 0.634, 0.134, 0.059)
    ) %>%
      group_by(party)
  }
  # create the graph
  df %>%
    e_charts(state_abbr, stack = "grp") %>%
    e_bar(value) %>%
    e_y_axis(formatter = e_axis_formatter("percent", digits = 2)) %>%
    e_tooltip(trigger = "axis", axisPointer = list(type = "shadow")) %>%
    e_legend(right = 10, top = 10) %>%
    e_color(c("#232066", "#E91D0E", "#f3b300", "#006900")) %>%
    e_tooltip(formatter = e_tooltip_item_formatter("percent", digits = 2))
})

Final Demo App

The full code of the election map...

Note: The shapes have to be manually downloaded before the app can be used.
In the given election app the shapes have also been simplified to 0.5% of their original size.

states <- raster::getData(country = "USA", level = 1)
counties <- raster::getData(country = "USA", level = 2)
# TODO replace the path to your downloaded shapes in the server code

library(shiny)
library(bs4Dash)
library(shinyjs)
library(leaflet)
library(leafdown)
library(echarts4r)
library(dplyr)
library(tidyr)
library(RColorBrewer)

ui <- bs4DashPage(
  title = "Leafdown Showcase - USA Election Data",
  navbar = bs4DashNavbar(tags$h3("Leafdown Showcase - USA Election Data", style = "margin-bottom: .2rem;")),
  bs4DashSidebar(disable = TRUE),
  body = bs4DashBody(
    # set the background of the map-container to be white
    tags$head(
      tags$style(HTML(".leaflet-container { background: #fff; height: 100%}")),
      # workaround for the NA in leaflet legend see https://github.com/rstudio/leaflet/issues/615
      tags$style(HTML(".leaflet-control div:last-child {clear: both;}")),
      tags$style(HTML(".card {height: 100%;}")),
      tags$style(HTML(".col-sm-12:last-child .card {margin-bottom: 0 !important;}")),
      tags$style(HTML("#leafdown {height: 80% !important; margin-top: 10px; margin-bottom: 10px;}"))
    ),
    # we need shinyjs for the leafdown map
    useShinyjs(),
    fluidRow(
      # a card for the map
      bs4Card(
        title = "Map",
        closable = FALSE,
        collapsible = FALSE,
        width = 6,
        # a dropdown to select what KPI should be displayed on the map
        selectInput(
          "map_sel", "Select what KPI to display on the map:",
          c("Votes" = "votes", "Unemployment" = "unemployment")
        ),
        # the two buttons used for drilling
        actionButton("drill_down", "Drill Down"),
        actionButton("drill_up", "Drill Up"),
        # the actual map element
        leafletOutput("leafdown")
      ),

      # a column with the two graphs
      column(
        width = 6,
        # box for racial makeup graph
        bs4Card(
          width = 12,
          closable = F,
          collapsible = F,
          title = "Racial makeup in percentages",
          echarts4rOutput("socio")
        ),
        # box for party percent graph
        bs4Card(
          width = 12,
          closable = F,
          collapsible = F,
          title = "Votes in percent",
          echarts4rOutput("party")
        )
      )
    )
  )
)

# Create user-defined function
percent <- function(x, digits = 2, format = "f", ...) { 
  paste0(formatC(x * 100, format = format, digits = digits, ...), "%")
}

create_labels <- function(data, map_level) {
  labels <- sprintf(
    "<strong>%s</strong><br/>
    Democrats: %s<br/>
    Republicans: %s<br/>
    Libertarians: %s<br/>
    Green: %s<br/>
    </sup>",
    data[, paste0("NAME_", map_level)],
    percent(data$Democrats2016),
    percent(data$Republicans2016),
    percent(data$Libertarians2016),
    percent(data$Green2016)
  )
  labels %>% lapply(htmltools::HTML)
}

# Define server for leafdown app
server <- function(input, output) {
  # load the shapes for the two levels
  # TODO load the shapes you have downloaded via the raster package
  states <- readRDS("../inst/app_election/us1.RDS")
  counties <- readRDS("../inst/app_election/us2.RDS")
  spdfs_list <- list(states, counties)

  # create leafdown object
  my_leafdown <- Leafdown$new(spdfs_list, "leafdown", input)

  rv <- reactiveValues()
  rv$update_leafdown <- 0

  # observers for the drilling buttons
  observeEvent(input$drill_down, {
    my_leafdown$drill_down()
    rv$update_leafdown <- rv$update_leafdown + 1
  })

  observeEvent(input$drill_up, {
    my_leafdown$drill_up()
    rv$update_leafdown <- rv$update_leafdown + 1
  })

  data <- reactive({
    req(rv$update_leafdown)
    # fetch the current metadata from the leafdown object
    data <- my_leafdown$curr_data

    # join the metadata with the election-data.
    # depending on the map_level we have different election-data so the 'by' columns for the join are different
    if (my_leafdown$curr_map_level == 2) {
      data$ST <- substr(data$HASC_2, 4, 5)
      # there are counties with the same name in different states so we have to join on both
      data <- left_join(data, us_election_counties, by = c("NAME_2", "ST"))
    } else {
      data$ST <- substr(data$HASC_1, 4, 5)
      data <- left_join(data, us_election_states, by = "ST")
    }
    # add the data back to the leafdown object
    my_leafdown$add_data(data)
    data
  })

  # this is where the leafdown magic happens
  output$leafdown <- renderLeaflet({
    req(spdfs_list)
    req(data)

    data <- data()

    # depending on the selected KPI in the dropdown we show different data
    if (input$map_sel == "unemployment") {
      data$y <- data$Unemployment * 100
      fillcolor <- leaflet::colorNumeric("Greens", data$y)
      legend_title <- "Unemployment in Percent"
    } else {
      data$y <- ifelse(data$Republicans2016 > data$Democrats2016, "Republicans", "Democrats")
      fillcolor <- leaflet::colorFactor(c("#232066", "#E91D0E"), data$y)
      legend_title <- "Winning Party"
    }

    labels <- create_labels(data, my_leafdown$curr_map_level)
    # draw the leafdown object
    my_leafdown$draw_leafdown(
      fillColor = ~ fillcolor(data$y),
      weight = 3, fillOpacity = 1, color = "white", label = labels
    ) %>%
      # set the view to be center on the USA
      setView(-95, 39, 4) %>%
      # add a nice legend
      addLegend(
        pal = fillcolor,
        values = ~ data$y,
        title = legend_title,
        opacity = 1
      )
  })

  # plots
  output$socio <- renderEcharts4r({
    df <- my_leafdown$curr_sel_data()
    # check whether any shape is selected, show basic info for the whole usa if nothing is selected
    if (nrow(df) > 0) {
      if (my_leafdown$curr_map_level == 1) {
        df <- df[, c("State", "Hispanic", "White", "Black", "Asian", "Amerindian", "Other")]
        df <- df %>%
          pivot_longer(2:7, "race") %>%
          group_by(State)
        df$value <- round(df$value, 2)
      } else {
        df <- df[, c("County", "Hispanic", "White", "Black", "Asian", "Amerindian", "Other")]
        df <- df %>%
          pivot_longer(2:7, "race") %>%
          group_by(County)
        df$value <- round(df$value / 100, 2)
      }
    } else {
      # show basic info for the whole usa as no state is selected
      df <- data.frame(
        ST = "USA",
        race = c("Hispanic", "White", "Black", "Asian", "Amerindian", "Other"),
        value = c(0.15, 0.634, 0.134, 0.059, 0.015, 0.027)
      ) %>%
        group_by(ST)
    }
    # create the graph
    df %>%
      e_charts(race) %>%
      e_bar(value) %>%
      e_tooltip(trigger = "axis", axisPointer = list(type = "shadow")) %>%
      e_y_axis(
        splitArea = list(show = FALSE),
        splitLine = list(show = FALSE),
        formatter = e_axis_formatter("percent", digits = 2)
      ) %>%
      e_legend(orient = "vertical", right = 10, top = 10) %>%
      e_color(brewer.pal(nrow(df), "Set3")) %>%
      e_tooltip(formatter = e_tooltip_item_formatter("percent"))
  })

  output$party <- renderEcharts4r({
    df <- my_leafdown$curr_sel_data()
    # check whether any shape is selected, show general election-result if nothing is selected
    if (nrow(df) > 0) {
      if (my_leafdown$curr_map_level == 1) {
        df <- df[, c("ST", "Democrats2016", "Republicans2016", "Libertarians2016", "Green2016")]
        df <- df %>%
          pivot_longer(2:5, "party") %>%
          group_by(party)
      } else {
        df <- df[, c("County", "Democrats2016", "Republicans2016", "Libertarians2016", "Green2016")]
        df <- df %>%
          pivot_longer(2:5, "party") %>%
          group_by(party)
        df$value <- df$value
        names(df)[1] <- "ST"
      }
    } else {
      # show general election-result as no state is selected
      df <- data.frame(
        party = c("Democrats2016", "Republicans2016", "Libertarians2016", "Green2016"),
        ST = "USA",
        value = c(0.153, 0.634, 0.134, 0.059)
      ) %>%
        group_by(party)
    }
    # create the graph
    df %>%
      e_charts(ST, stack = "grp") %>%
      e_bar(value) %>%
      e_y_axis(formatter = e_axis_formatter("percent", digits = 2)) %>%
      e_tooltip(trigger = "axis", axisPointer = list(type = "shadow")) %>%
      e_legend(right = 10, top = 10) %>%
      e_color(c("#232066", "#E91D0E", "#f3b300", "#006900")) %>%
      e_tooltip(formatter = e_tooltip_item_formatter("percent", digits = 2))
  })
}

shinyApp(ui, server)