# Connection to other Shiny elements

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

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)

You can find the full demo app hosted on shinyapps.io