Last active
April 13, 2023 16:29
-
-
Save plnnr/d3445e1a8d4a15b245281b88b2e72a2f to your computer and use it in GitHub Desktop.
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.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment