From a0b7d2fdf90b89fc5ff0ff863e572292ad16f578 Mon Sep 17 00:00:00 2001 From: syounkin Date: Fri, 22 Nov 2024 10:24:46 -0600 Subject: [PATCH 1/3] Added Table to WI-schools-cycle.Rmd Used package reactable to create a table of non.cycleway values. North High in Eau Claire had the shortest median duration of 4.9 min. and River Ridge High the longest at 17.9 min. --- WI-schools-cycle.Rmd | 77 +++++++++++++++++++++++++++++--------------- 1 file changed, 51 insertions(+), 26 deletions(-) diff --git a/WI-schools-cycle.Rmd b/WI-schools-cycle.Rmd index 3f8b5aa..b2c76aa 100644 --- a/WI-schools-cycle.Rmd +++ b/WI-schools-cycle.Rmd @@ -22,13 +22,14 @@ library(tidyverse) library(ggmap) library(sf) library(osrm) -library(smoothr) -library(magick) -library(ggnewscale) -library(rsvg) -library(httr) -library(jsonlite) -library(parallel) +## library(smoothr) +## library(magick) +## library(ggnewscale) +## library(rsvg) +## library(httr) +## library(jsonlite) +## library(parallel) +library(reactable) fig.height <- 6 set.seed(1) source("./R/functions.R") @@ -37,13 +38,13 @@ runLoop <- FALSE ## Configuration -```{r config, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +```{r config, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} options(osrm.server = "http://127.0.0.1:5001/") options(osrm.profile = "bike") brouter_url <- "http://127.0.0.1:17777/brouter" brouter_profile <- "safety" register_stadiamaps(key = substr(read_file(file = "api_keys/stadia_api_key"), 1, 36)) -WI_schools <- st_transform(st_read(dsn = "data/Schools/Wisconsin_Public_Schools_-5986231931870160084.gpkg"), crs = 4326) +WI_schools <- st_transform(st_read(dsn = "data/Schools/Wisconsin_Public_Schools_-5986231931870160084.gpkg", quiet = TRUE), crs = 4326) WI_schools <- WI_schools %>% mutate(geom = SHAPE) ``` @@ -142,7 +143,7 @@ saveRDS(routesList, "./R/data/routesList.rds") ## Read List Data -```{r readLists, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +```{r readLists, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} routesList <- readRDS(file = "./R/data/routesList.rds") gridList <- readRDS(file = "./R/data/gridList.rds") WI_schools <- readRDS(file = "./R/data/WI_schools.rds") @@ -175,26 +176,22 @@ for(j in 1:length(gridList)){ ## Plot List Data -### Best & Worst Schools +### Shortest and Longest Median Non-Cycleway Duration -```{r plots, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +First we take a look at the schools with the shortest and longest +median time on cycleway. + +#### Longest + + + +```{r worst, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} ggplot(data.frame(not.cycleway = not.cycleway.vec), aes(not.cycleway)) + geom_histogram(fill = "grey", color = "black") + theme_bw() register_stadiamaps(key = substr(read_file(file = "api_keys/stadia_api_key"), 1, 36)) - +k <- 306 zoom.level <- 15 -k <- 306 #247 -bbox <- st_bbox(st_buffer(gridList[[k]], 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 = zoom.level, maptype = "stamen_toner_lite") - -ggmap(basemap) + geom_sf(data = gridList[[k]], aes(fill= not.cycleway), inherit.aes = FALSE) + scale_fill_gradient(low = "yellow", high = "red", limits = c(0,17), na.value = NA) - -k <- 247 #306 bbox <- st_bbox(st_buffer(gridList[[k]], dist = 500)) bbox <- c(left = as.double(bbox[1]), @@ -206,9 +203,28 @@ basemap <- get_stadiamap(bbox = bbox, zoom = zoom.level, maptype = "stamen_toner ggmap(basemap) + geom_sf(data = gridList[[k]], aes(fill= not.cycleway), inherit.aes = FALSE) + scale_fill_gradient(low = "yellow", high = "red", limits = c(0,17), na.value = NA) ``` +The longest is `r WI_schools[k,] |> pull(SCHOOL)`. + +#### Shortest + +```{r best, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +k <- 247 + +bbox <- st_bbox(st_buffer(gridList[[k]], 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 = zoom.level, maptype = "stamen_toner_lite") + +ggmap(basemap) + geom_sf(data = gridList[[k]], aes(fill= not.cycleway), inherit.aes = FALSE) + scale_fill_gradient(low = "yellow", high = "red", limits = c(0,17), na.value = NA) +``` + +The shortest is `r WI_schools[k,] |> pull(SCHOOL)`. + ### Statewide Map -```{r plots2, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +```{r plots2, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} D <- cbind(WI_schools, not.cycleway.vec) @@ -225,9 +241,18 @@ ggmap(basemap) + geom_sf(data = D, aes(size = 2, color = not.cycleway.vec), inhe ``` +### Statewide Table + +```{r table, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +D_table <- as.data.frame(cbind(WI_schools, not.cycleway.vec)) +D <- select(D_table, SCHOOL, COUNTY, NONCYCLEWAY = not.cycleway.vec) +D <- D |> mutate(NONCYCLEWAY = round(NONCYCLEWAY,1)) +reactable(D) +``` + # Archive -```{r chunklast, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +```{r chunklast, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} date() sessionInfo() ``` From 15656c9ca0c7d038ae765973db379dec8013f8cc Mon Sep 17 00:00:00 2001 From: syounkin Date: Fri, 22 Nov 2024 11:01:29 -0600 Subject: [PATCH 2/3] Moved route_to_school.Rmd to archive --- route_to_school.Rmd => archive/route_to_school.Rmd | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename route_to_school.Rmd => archive/route_to_school.Rmd (100%) diff --git a/route_to_school.Rmd b/archive/route_to_school.Rmd similarity index 100% rename from route_to_school.Rmd rename to archive/route_to_school.Rmd From d0eecdc2c5742e430aeb4f75352d63cb86decb88 Mon Sep 17 00:00:00 2001 From: syounkin Date: Fri, 22 Nov 2024 11:08:43 -0600 Subject: [PATCH 3/3] Added descriptive text to WI-schools-cycle.Rmd --- Makefile | 3 +- WI-schools-cycle.Rmd | 74 +++++++++++++++++++++++++++++++------------- 2 files changed, 55 insertions(+), 22 deletions(-) diff --git a/Makefile b/Makefile index e69b36e..eb42337 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,8 @@ all: data containers cycle data: osrm-data brouter-data containers: osrm-container brouter-container -cycle: WI-schools-cycle +WI-cycle: WI-schools-cycle +cycle: cycle_brouter 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")' diff --git a/WI-schools-cycle.Rmd b/WI-schools-cycle.Rmd index b2c76aa..b7971a5 100644 --- a/WI-schools-cycle.Rmd +++ b/WI-schools-cycle.Rmd @@ -11,24 +11,20 @@ editor_options: chunk_output_type: console --- +```{r preCode, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +date() +``` + # Input Data & Configuration ## Libraries ```{r libs, eval = TRUE, echo = FALSE, 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) library(reactable) fig.height <- 6 set.seed(1) @@ -38,6 +34,8 @@ runLoop <- FALSE ## Configuration +Set configuration parameters for OSRM, brouter, and stadiamaps. + ```{r config, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} options(osrm.server = "http://127.0.0.1:5001/") options(osrm.profile = "bike") @@ -48,16 +46,32 @@ WI_schools <- st_transform(st_read(dsn = "data/Schools/Wisconsin_Public_Schools_ WI_schools <- WI_schools %>% mutate(geom = SHAPE) ``` +# Analysis + +We focus on the statistic *non-cycleway duration* in this analysis. It +is computed as the duration (in minutes) of the bike trip to school +(brouter, safety) for each grid cell in the school's bikeable +area. A bikeable area is defined as the region within 3 miles of +school by bike (OSRM). + ## Subset Schools ```{r subsetSchools, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} WI_schools <- subset(WI_schools, !is.na(LAT) & !is.na(LON) & GRADE_RANGE == "09-12") ``` -Non-virtual, grades 9-12. +We keep only schools with coordinates (non-virtual) and, for +simplicity and efficiency of the initial analysis, we keep only +schools with grades 9-12. ## Loop through WI Schools +For each school we compute the grid and the routes sf objects and save +them as lists as R data files, _gridList.rds_ and +_routesList.rds_. These will then be analyzed downstream and this loop +need not be run again. It took around 40 minutes to run. The code here +is suppressed because it is long and ugly. + ```{r mainloop, eval = runLoop, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = TRUE} radius <- 3 # miles levels <- c(1) @@ -176,18 +190,31 @@ for(j in 1:length(gridList)){ ## Plot List Data -### Shortest and Longest Median Non-Cycleway Duration +### Median Non-Cycleway Duration -First we take a look at the schools with the shortest and longest -median time on cycleway. +#### Histogram + +First we investigate the distribution of median non-cycleway duration +across school. Recall that we are considering now only schools grade +9-12. + +```{r hist, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +ggplot(data.frame(not.cycleway = not.cycleway.vec), aes(not.cycleway)) + geom_histogram(fill = "orange", color = "black") + theme_bw() +``` + +Next, we take a look at the schools with the shortest and longest +median time on cycleway. Note that the analysis is peformed across a +gridded area and not with respect to where students live. The median +non-cycleway duration is computed across grid cells, not students. + +Note too that this statistics was computed by parsing the *messages* +field of the route returned by brouter. I am not sure if there is a +better way to do this. Within the messages field there is information +on highway type, surface, etc for each segment of the route. #### Longest - - -```{r worst, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} -ggplot(data.frame(not.cycleway = not.cycleway.vec), aes(not.cycleway)) + geom_histogram(fill = "grey", color = "black") + theme_bw() - +```{r worst, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = FALSE} register_stadiamaps(key = substr(read_file(file = "api_keys/stadia_api_key"), 1, 36)) k <- 306 zoom.level <- 15 @@ -207,7 +234,7 @@ The longest is `r WI_schools[k,] |> pull(SCHOOL)`. #### Shortest -```{r best, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +```{r best, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = FALSE} k <- 247 bbox <- st_bbox(st_buffer(gridList[[k]], dist = 500)) @@ -224,7 +251,7 @@ The shortest is `r WI_schools[k,] |> pull(SCHOOL)`. ### Statewide Map -```{r plots2, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +```{r plots2, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = FALSE} D <- cbind(WI_schools, not.cycleway.vec) @@ -243,16 +270,21 @@ ggmap(basemap) + geom_sf(data = D, aes(size = 2, color = not.cycleway.vec), inhe ### Statewide Table +The values shown above can be seen below in this clickable table. + ```{r table, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} D_table <- as.data.frame(cbind(WI_schools, not.cycleway.vec)) D <- select(D_table, SCHOOL, COUNTY, NONCYCLEWAY = not.cycleway.vec) D <- D |> mutate(NONCYCLEWAY = round(NONCYCLEWAY,1)) reactable(D) ``` +```{r date, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +date() +``` # Archive -```{r chunklast, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} -date() +## Session Info +```{r sessionInfo, eval = TRUE, echo = FALSE, results = "show", warning = TRUE, error = TRUE, message = TRUE} sessionInfo() ```