Shiny dashboard app that loads OD data from StreetLight and allows users to explore origin-destination pairs. Has some bugs with the class breaks but mostly functions. Will update periodically.

stl_od_explorer_shiny_app.R

library(shiny)
library(shinydashboard)
library(dplyr)
library(tidyr)
library(sf)
library(mapview)
library(DT)
# library(tigris)
library(leaflet)
# library(leafsync)
library(classInt)
# library(reactlog) # 
# reactlog::reactlog_enable() # https://mastering-shiny.org/reactive-graph.html

analysis_name <- "All Zones OD All Veh LBS+ 2022 JanApr" #"All Zones OD All Veh LBS+ 2019" # "EB Zones OD All Veh LBS+ 2020"
shape_loc <- "shapes/zone_set_Transbay_Zones_CatchmentTransPed_Removed.shp"
# ebzones <- "shapes/eb/zone_set_East_Bay_Service_Area.shp"

# library(streetlightR)
# odstl <- get_analysis_data(analysis_name, metric = "od_all")
# odstl %>%
#   mutate(avg_travel_time_sec = as.numeric(avg_travel_time_sec)) %>%
#   select(-c(data_periods, mode_of_travel, data_periods, mode_of_travel,
#             origin_zone_is_pass_through, origin_zone_direction_degrees,
#             origin_zone_is_bi_direction, destination_zone_is_pass_through,
#             destination_zone_direction_degrees, destination_zone_is_bi_direction)) %>%
#   complete(
#     origin_zone_name, destination_zone_name,
#     fill = list(average_daily_o_d_traffic_st_l_volume = 0,
#                 average_daily_origin_zone_traffic_st_l_volume = NA_real_,
#                 avg_travel_time_sec = NA_real_) ) %>% 
#   saveRDS(., paste0(analysis_name, ".rds"))
od_data <- readRDS(paste0(analysis_name, ".rds")) 
od.sf <- st_read(shape_loc) 

# Debug
# {
# debug_origin <- od_data %>%
#   filter(origin_zone_name == "Alameda, CA34", # Downtown Oakland, Oakland, CA27
#          day_type == "0: All Days (M-Su)", #  0: All Days (M-Su)  unique(od_data$day_type)
#          day_part == "1: Early AM (12am-6am)") # 0: All Day (12am-12am) unique(od_data$day_part)
# length(unique(debug_origin$average_daily_o_d_traffic_st_l_volume))
# 
# classIntervals(debug_origin$average_daily_o_d_traffic_st_l_volume, 
#                n = 5, style = "jenks")
# }

choices_day_types <- sort(unique(od_data$day_type))
choices_day_parts <- sort(unique(od_data$day_part))
choices_target_zones <- sort(unique(od_data$origin_zone_name))


ui <- dashboardPage(
  skin = "black",
  dashboardHeader(title = "Origin-Destination Explorer DEMO", titleWidth = "340"),
  
  dashboardSidebar(width = "280",
                   
                   div(style="padding: 15px 15px 15px 15px;", "This visualization maps origin-destination vehicle trips across the region derived from ", tags$a(href="https://www.streetlightdata.com","StreetLight's"), " location-based service (LBS) data. Data reflect averages from January 1, 2022 to April 30, 2022."),
                   
                   selectInput(inputId = 'day_type', 
                               label = 'Day Type:', 
                               selected = "0: All Days (M-Su)", 
                               choices = choices_day_types),
                   
                   selectInput(inputId = 'day_part', 
                               label = 'Time of Day:', 
                               selected = "0: All Day (12am-12am)", 
                               choices = choices_day_parts),
                   
                   selectInput(inputId = 'target_zone', 
                               label = 'Target Zone', 
                               selected = "Downtown Oakland, Oakland, CA27", 
                               choices = choices_target_zones),
                   
                   radioButtons(inputId = "od_directionality", label = "Target Zone as:", 
                                choices = c("Origin", "Destination"), 
                                selected = "Origin", inline = TRUE),
                   
                   # radioButtons(inputId = "ebzones", label = "Geographic Extent:", 
                   #              choices = c("East Bay", "Greater Region"), 
                   #              selected = "Greater Region", inline = TRUE),
                   
                   uiOutput('legend_controls'),
                   
                   div(style="padding: 15px 15px 15px 15px;", "Source: ", tags$a(href="https://www.streetlightdata.com","StreetLight"), " and ", tags$a(href="http://www.actransit.org","AC Transit."), " Prepared March 2, 2023 by AC Transit Business Sciences Department. Contact point: ", tags$a(href="mailto:nkobel@actransit.org","Nick Kobel"),".")),
  
  dashboardBody(
    
    tabBox(
      # The id lets us use input$tabset1 on the server to find the current tab
      id = "tabset1", height = "250px", width = "100%",
      tabPanel("Map", 
               tags$style(type = "text/css", "#odmap {height: calc(100vh - 140px) !important;}"),
               leafletOutput("odmap")
               ),
      tabPanel("Summary", 
               h4("Top 10 Zones to/from Target Zone"),
               h5("(Percent of Traffic Volume)"),
               DT::dataTableOutput("summarypct")
               
      )
    )
    
  )
)


server <- function(input, output, session) {
  
  # Set event listeners that trigger a map legend break re-calc
  listenBreaks <- reactive({
    list(input$day_type, input$day_part, input$target_zone) # input$od_directionality
  })
  
  # Listener for map breaks which updates the slider input 
  observeEvent(listenBreaks(), ignoreInit = TRUE, priority = 2, {
    # https://stackoverflow.com/questions/41960953/how-to-listen-for-more-than-one-event-expression-within-a-shiny-observeevent
    message("Event triggered.")
    updateSliderInput(session, inputId = "map_breaks", value = max_breaks())
  })
  
  # Map leaflet object
  output$odmap <- renderLeaflet({
    leaflet() %>%
      addProviderTiles('CartoDB.Positron') %>%
      setView(lng = -122.14501, lat =  37.74779, zoom = 10)
  })
  
  # Target zone based on input
  target_zone <- reactive({
    # Make sure requirements are met
    req(input$target_zone)
    
    od.sf %>%
      filter(name == input$target_zone)
  })
  
  # List of values to assist with directionality based off the orig/dest toggle
  directionality <- reactiveValues()
  observeEvent(input$od_directionality, {
    if (input$od_directionality == 'Origin') {
      directionality$target_zone_name = 'origin_zone_name'
      directionality$target_opposite_zone_name = 'destination_zone_name'
      directionality$target_opposite_traffic = 'average_daily_destination_zone_traffic_st_l_volume'
      directionality$start_end = "ending"
    } else if (input$od_directionality == 'Destination') {
      directionality$target_zone_name = 'destination_zone_name'
      directionality$target_opposite_zone_name = 'origin_zone_name'
      directionality$target_opposite_traffic = 'average_daily_origin_zone_traffic_st_l_volume'
      directionality$start_end = "starting"
    } 
  })
  
  # Complementary data associated with the target zone. I.e., if target zone is
  # set as destination, this reactive returns the origins associated with that 
  # destination. Note the use of.data[[]] notation to "complete" the table. The 
  # completion helps fill in missing data gaps so the map looks mostly complete
  od_pairs <- reactive({
    req(directionality$target_zone_name)
    
    od_data %>% 
      filter(.data[[directionality$target_zone_name]] == input$target_zone) %>% 
      complete(
        .data[[directionality$target_zone_name]],
        .data[[directionality$target_opposite_zone_name]],
        day_type, day_part,
        # nesting(item_id, item_name),
        fill = list(average_daily_o_d_traffic_st_l_volume = 0,
                    average_daily_origin_zone_traffic_st_l_volume = NA_real_,
                    avg_travel_time_sec = NA_real_) )
    # browser()
  })
  
  # Filtered dataset based off user input
  filtered_data <- reactive({
    od_pairs() %>%
      filter(day_type == input$day_type,
             day_part == input$day_part) %>%
      # https://stackoverflow.com/questions/49650394/how-to-rename-a-variable-using-a-dynamic-name-and-dplyr
      left_join(., rename(od.sf, !!quo_name(directionality$target_opposite_zone_name) := name),
                by = directionality$target_opposite_zone_name) %>%
      st_as_sf()
    # browser()
  })
  
  # Summary data
  summary_data <- reactive({
    df <- filtered_data() %>% 
      st_drop_geometry() %>% 
      mutate(pct_volume = average_daily_o_d_traffic_st_l_volume / .data[[directionality$target_opposite_traffic]])
    
    df.pct <- df %>% 
      arrange(desc(pct_volume)) %>% 
      slice_max(order_by = pct_volume, n = 10) %>% 
      mutate(pct_volume = round(pct_volume * 100, 1.1),
             `Average Travel Time (Min)` = round(avg_travel_time_sec/60, 1.1)) %>% 
      select(.data[[directionality$target_opposite_zone_name]], 
             `Pct of Traffic Volume` = pct_volume,
             `Average Travel Time (Min)`)
    
    df.vol <- df %>% 
      arrange(average_daily_o_d_traffic_st_l_volume) %>% 
      slice_max(order_by = average_daily_o_d_traffic_st_l_volume, n = 10) %>%
      mutate(`Average Travel Time (Min)` = round(avg_travel_time_sec/60, 1.1)) %>% 
      select(.data[[directionality$target_opposite_zone_name]], 
             `Total Traffic Volume` = average_daily_o_d_traffic_st_l_volume,
             `Average Travel Time (Min)`)
    
    summary <- list(pct_trips = df.pct,
                    tot_trips = df.vol)
    
    summary
    # browser()
  })
  
  # data table output. See options https://rstudio.github.io/DT/options.html
  output$summarypct <- DT::renderDataTable({
    DT::datatable(summary_data()$pct_trips, options = list(dom = 't'))
  })
  
  # Maximum number of map breaks based off the number of unique values within a 
  # dataset, which is necessary to block app crashing due to insufficient map cuts
  max_breaks <- reactive({
    data_range_max <- floor(length(unique(filtered_data()$average_daily_o_d_traffic_st_l_volume)) / 8)
    # override if proposed range is > 10
    if (data_range_max > 10){
      data_range_max <- 10
    }
    data_range_max
  })
  
  # Dynamic UI to change the maximum number of breaks based off the filtered data
  output$legend_controls <- renderUI({
    tagList(
      sliderInput(inputId = 'map_breaks',
                  label = 'Number of Legend Breaks',
                  min = 2, max = max_breaks(), 
                  value = max_breaks()) # ceiling(max_breaks() / 4)
    )
  })
  
  
  # triggerClasses <- reactive({
  #   list(input$day_type, input$day_part, input$target_zone, input$od_directionality, max_breaks(), input$ebzones)
  # })
  
  # List of legend classes (break points and names of those break points), which
  # uses Jenks natural breaks based off the distribution of the data
  # TODO This is a source of the map crashing when switching to low-traffic zones
  classes <- reactive({
    req(filtered_data())
    req(max_breaks())
    req(input$map_breaks)
    
    nbrk <- input$map_breaks
    
    classes <- classIntervals(filtered_data()$average_daily_o_d_traffic_st_l_volume, 
                              n = nbrk, style = "jenks")
    
    classes$names <- c()
    
    for( i in seq_along(classes$brks) ){
      if (i == nbrk+1) {
        break
      } else{
        rangename <- paste0(classes$brks[i]+1, " to ", classes$brks[i+1])
        classes$names <- c(classes$names, rangename)
      }
    }
    
    message(paste0(classes$names, sep = "\n"))
    
    classes
  })
  
  # Set event listeners that trigger a map data re-calc
  triggerMap <- reactive({
    list(classes(), input$day_type, input$day_part, input$target_zone, input$od_directionality, input$map_breaks, input$ebzones)
  })
  
  # Map data that is re-calculated to dynamically re-label legend breaks to more
  # human-readable format. I.e., [0, 13) to '0 to 13'.
  map_data <- eventReactive(triggerMap(), {
    req(classes())
    
    filtered_data() %>%
      mutate(brks = cut(average_daily_o_d_traffic_st_l_volume, classes()$brks,
                        include.lowest = T) %>%
               factor(., labels = classes()$names))
  })
  
  # Event listener that updates the map
  observe({
    req(map_data())
    
    # browser()
    
    # StreetLight-style origin-destination colors; optional
    # stl_color_orig <- '#7ab0f5' 
    # stl_color_dest <- '#ffda6a' 
    
    # Change map colors based on directionality
    if (input$od_directionality == 'Origin'){
      target_zone_color <- "cyan" # stl_color_orig
    } else { 
      target_zone_color <- "magenta" # stl_color_dest 
    }
    
    # Important proxy referencing leaflet object
    proxy <- leafletProxy("odmap", data = map_data())
    
    # StreetLight Volume palette function based on map breaks
    pal_stlv <- colorFactor("inferno", map_data()$brks)
    
    # Update proxy object
    proxy %>% 
      clearShapes() %>% clearMarkers() %>% clearControls() %>%
      addPolygons(
        fillColor = ~pal_stlv(map_data()$brks),
        weight = 0.8,
        opacity = 1,
        color = "white",
        # popup = popup,
        fillOpacity = 0.5,
        label = ~paste0(average_daily_o_d_traffic_st_l_volume, " trips ", 
                        directionality$start_end, " at ", 
                        # See use of get() at https://stackoverflow.com/questions/6034655/convert-string-to-a-variable-name
                        get(directionality$target_opposite_zone_name))
      ) %>%
      addPolygons(
        data = target_zone(),
        group = "Target Zone",
        color = target_zone_color,
        opacity = 1,
        weight = 2.5,
        fill = FALSE
      ) %>% 
      addLegend("topright",
                pal = pal_stlv,
                values = map_data()$brks,
                title = "StreetLight Volume",
                opacity = 0.6
      ) 
  })
}


shinyApp(ui = ui, server = server)