Created route_to_school.Rmd

This script is a spin-off of cycle_route_analysis_brouter.Rmd.

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
 

R/data/.gitignore

@@ -0,0 +1,4 @@
+# Ignore everything in this directory
+*
+# Except this file
+!.gitignore

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)
+    }
+
+}

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()
+```