From d1b1fd0253cec41c965730a3b312eb083d844bb5 Mon Sep 17 00:00:00 2001 From: syounkin Date: Wed, 13 Nov 2024 14:00:07 -0600 Subject: [PATCH] Created route_to_school.Rmd This script is a spin-off of cycle_route_analysis_brouter.Rmd. --- Makefile | 5 +- R/data/.gitignore | 4 + R/functions.R | 47 +++++++++++ route_to_school.Rmd | 198 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 253 insertions(+), 1 deletion(-) create mode 100644 R/data/.gitignore create mode 100644 route_to_school.Rmd diff --git a/Makefile b/Makefile index ee206b4..009db84 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ all: data containers cycle data: osrm-data brouter-data containers: osrm-container brouter-container -cycle: cycle_brouter +cycle: route_to_school walk: route_analysis.Rmd R -e 'library("rmarkdown"); old_path <- Sys.getenv("PATH"); Sys.setenv(PATH = paste(old_path, "/usr/local/bin", sep = ":")); rmarkdown::render(knit_root_dir = "./", output_dir = "./html", input = "./route_analysis.Rmd", output_file = "./html/route_analysis.html")' @@ -13,6 +13,9 @@ cycle_osrm: cycling_route_analysis.Rmd cycle_brouter: cycling_route_analysis_brouter.Rmd R -e 'library("rmarkdown"); old_path <- Sys.getenv("PATH"); Sys.setenv(PATH = paste(old_path, "/usr/local/bin", sep = ":")); rmarkdown::render(knit_root_dir = "./", output_dir = "./html", input = "./cycling_route_analysis_brouter.Rmd", output_file = "./html/cycling_route_analysis.html")' +route_to_school: route_to_school.Rmd + R -e 'library("rmarkdown"); old_path <- Sys.getenv("PATH"); Sys.setenv(PATH = paste(old_path, "/usr/local/bin", sep = ":")); rmarkdown::render(knit_root_dir = "./", output_dir = "./html", input = "./route_to_school.Rmd", output_file = "./html/route_to_school.html")' + osrm-container: ./docker/osrm/docker-compose.yml cd ./docker/osrm/; docker compose up -d diff --git a/R/data/.gitignore b/R/data/.gitignore new file mode 100644 index 0000000..5e7d273 --- /dev/null +++ b/R/data/.gitignore @@ -0,0 +1,4 @@ +# Ignore everything in this directory +* +# Except this file +!.gitignore diff --git a/R/functions.R b/R/functions.R index c24604a..0f3f2de 100644 --- a/R/functions.R +++ b/R/functions.R @@ -32,3 +32,50 @@ getLTSForRoute <- function(i) { return(result) } + + +routeChar <- function(route){ + +text <- as.data.frame(route)$messages +text <- gsub(x = text, pattern = "\\\"", replacement = "") +text <- gsub(x = text, pattern = "\ ", replacement = "") +text <- gsub(x = text, pattern = "\\[\\[", replacement = "") +text <- gsub(x = text, pattern = "\\]\\]", replacement = "") +foobar <- strsplit(text, split = "],[", fixed = TRUE) +x <- lapply(foobar, function(x){strsplit(x, split = ",", fixed = TRUE)}) +xx <- unlist(x) +m <- matrix(xx, ncol = 13, byrow = TRUE) +df <- data.frame(m[-1,]) +names(df) <- m[1,] + + +df2 <- within(df, { + Time <- as.numeric(Time) + stageTime <- diff(c(0,Time)) + path <- grepl("highway=path", df$WayTags) + residential <- grepl("highway=residential", df$WayTags) + footway <- grepl("highway=footway", df$WayTags) + primary <- grepl("highway=primary", df$WayTags) + service <- grepl("highway=service", df$WayTags) + cycleway <- grepl("highway=cycleway", df$WayTags) + bike <- grepl("bicycle=designated", df$WayTags) +}) + + +foo <- function(x){ + ifelse(x$path, "path", ifelse(x$residential, "residential", ifelse(x$footway, "footway", ifelse(x$primary, "primary", ifelse(x$service, "service", ifelse(x$cycleway, "cycleway", "other")))))) +} + +df2 <- cbind(df2, highway = foo(df2)) +df2 <- df2 %>% group_by(highway) %>% summarize(T = sum(stageTime)) + +df2 <- df2 %>% filter(!is.na(highway)) + + + if(!("cycleway" %in% df2$highway)){ + return(0) + }else{ + return(df2[df2$highway == "cycleway",]$T) + } + +} diff --git a/route_to_school.Rmd b/route_to_school.Rmd new file mode 100644 index 0000000..0758473 --- /dev/null +++ b/route_to_school.Rmd @@ -0,0 +1,198 @@ +--- +title: "East High Cycling Routes" +output: + html_document: + toc: true + toc_depth: 5 + toc_float: + collapsed: false + smooth_scroll: true +editor_options: + chunk_output_type: console +--- + +# Input Data & Configuration + +## Libraries + +```{r libs, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +date() +rm(list=ls()) +library(tidyverse) +library(ggmap) +library(sf) +library(osrm) +library(smoothr) +library(magick) +library(ggnewscale) +library(rsvg) +library(httr) +library(jsonlite) +library(parallel) +fig.height <- 6 +set.seed(1) +makePlots <- TRUE +source("./R/functions.R") +``` + +# External sources configurations + +## Open Source Routing Machine (OSRM) + +```{r osrm, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +# Set url and profile of OSRM server +options(osrm.server = "http://127.0.0.1:5001/") +options(osrm.profile = "bike") +``` + +## Brouter options +```{r brouter, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +# Set url and profile of brouter server +brouter_url <- "http://127.0.0.1:17777/brouter" +brouter_profile <- "safety" +``` + +## Stadia Maps API Key + +```{r stadiamaps, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +register_stadiamaps(key = substr(read_file(file = "api_keys/stadia_api_key"), 1, 36)) +``` + + +# Analysis + +## Create Bikeable Region Using OSRM + +```{r boundary, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +WI_schools <- st_transform(st_read(dsn = "data/Schools/Wisconsin_Public_Schools_-5986231931870160084.gpkg"), crs = 4326) +WI_schools <- WI_schools %>% mutate(geom = SHAPE) + +school_focus <- data.frame(name = c("East High School"), NCES_CODE = c("550852000925")) +#school_focus <- data.frame(name = c("IMAP"), NCES_CODE = c("550008203085")) +school_location <- WI_schools %>% filter(NCES_CODE %in% school_focus$NCES_CODE) + +radius <- 3 # miles +levels <- c(1) +res <- 100 +threshold <- units::set_units(1, km^2) + +cycle_boundary_m <- radius*1609 + +cycle_boundary_poly <- osrmIsodistance( loc = school_location, breaks = cycle_boundary_m, res = res ) + +cycle_boundary_poly <- st_make_valid(cycle_boundary_poly) + +cycle_boundary_poly <- fill_holes(cycle_boundary_poly, threshold) + +cycle_boundary_poly <- st_transform(cycle_boundary_poly, crs = 4326) + +saveRDS(cycle_boundary_poly, "./R/data/cycle_boundary_poly.rds") +``` + +# Create Grid Over Bikeable Region + +```{r grid, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +cellsize <- 5e-3 +grid <- st_intersection(cycle_boundary_poly, st_make_grid(cycle_boundary_poly, cellsize = cellsize, what = "polygons", square = FALSE)) +``` + +# Compute Routes from Cell Centroids to School with brouter + +```{r routes, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +grid_pts <- st_centroid(grid) +grid_coods <- st_coordinates(grid_pts) +school_focus_location <- WI_schools %>% filter(NCES_CODE %in% school_focus$NCES_CODE) %>% select(LAT, LON) + +routes <- list(NULL) +for(i in 1:nrow(grid_coods) ) { + query <- paste0( + brouter_url, + "?lonlats=", grid_coods[i,1], ",",grid_coods[i,2], "|", + school_focus_location$LON, ",", school_focus_location$LAT, + "&profile=", brouter_profile, + "&alternativeidx=0&format=geojson" + ) + response <- GET(query) + route_run <- st_read(content <- content(response, as = "text"), quiet = TRUE) + route_run[["student_number"]] <- i + routes[[i]] <- route_run +} + +routes <- st_transform(bind_rows(routes), crs = 4326) +``` + +Notes: + +- What does `st_transform(bind_rows(routes), crs = 4326)` do? + + +# Generate Map for Total Time + +## Set boundaries and get basemap +```{r basemap, eval = makePlots, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +bbox <- st_bbox(st_buffer(cycle_boundary_poly, dist = 500)) +bbox <- c(left = as.double(bbox[1]), + bottom = as.double(bbox[2]), + right = as.double(bbox[3]), + top = as.double(bbox[4])) + +basemap <- get_stadiamap(bbox = bbox, zoom = 15, maptype = "stamen_toner_lite") +``` + +## Route Characteristic Map + +```{r sandbox3, eval = makePlots, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +track.length.vec <- routes %>% pull(track.length) +grid <- cbind(grid, track.length = as.numeric(track.length.vec)/1609) + +total.time.vec <- routes %>% pull(total.time) +grid <- cbind(grid, total.time = as.numeric(total.time.vec)/60) + +total.energy.vec <- routes %>% pull(total.energy) +grid <- cbind(grid, total.energy = as.numeric(total.energy.vec)) + +gg1 <- ggmap(basemap) + geom_sf(data = grid, aes(fill = total.time), inherit.aes = FALSE) + +ggsave(gg1, filename = "./figures/route-characteristics.pdf", width = 11, height = 8, units = "in") + +gg1 +``` +## Routes Map + +```{r sandbox3b, eval = makePlots, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +gg2 <- ggmap(basemap) + geom_sf(data = routes, aes(color = "red"), inherit.aes = FALSE) +ggsave(gg2, filename = "./figures/routes.pdf", width = 11, height = 8, units = "in") +gg2 +``` + +# Available Route Data + +## Investigatioin of Messages Data + +```{r sandbox4, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +x.vec <- c() +for(j in 1:nrow(routes)){ + foobar <- routeChar(routes[j, "messages"]) + x.vec <- c(x.vec, foobar) +} + +new.df <- cbind(grid, T.cycleway = x.vec) + +gg3 <- ggmap(basemap) + geom_sf(data = new.df, aes(fill= T.cycleway/60), inherit.aes = FALSE) +ggsave(gg3, filename = "./figures/routes.pdf", width = 11, height = 8, units = "in") +gg3 +``` + +# Message Data? + +What information can we pull out of the messages data? + +```{r sandbox5, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +routes[1,"messages"] +``` + + +```{r chunklast, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +date() +sessionInfo() +```