inst/doc/Connection_to_other_elements.R

In leafdown: Provides Drill Down Functionality for 'leaflet' Choropleths

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

## ---- echo=FALSE, out.width="100%"--------------------------------------------
knitr::include_graphics("../man/figures/app_election_map.png")

## ---- eval = FALSE------------------------------------------------------------
#  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")
#    )
#  )

## ---- eval = FALSE------------------------------------------------------------
#  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))
#  })

## ---- eval=FALSE--------------------------------------------------------------
#  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

## ---- eval=FALSE--------------------------------------------------------------
#  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)
#