From 0c9b3e070fb3545cda95a4b1a998be1f0f28e342 Mon Sep 17 00:00:00 2001 From: syounkin Date: Thu, 21 Nov 2024 14:48:22 -0600 Subject: [PATCH] Update to WI-schools-cycle.Rmd Trying to get through all grade 9-12 schools in WI. Some schools have no routes, no coordinates, etc. Working my way through all the special cases. --- R/functions.R | 70 +++++++++++++++++++++++++------------------- WI-schools-cycle.Rmd | 59 +++++++++++++++++++++++++++++++++---- 2 files changed, 93 insertions(+), 36 deletions(-) diff --git a/R/functions.R b/R/functions.R index 1e70ff8..b6dc7d6 100644 --- a/R/functions.R +++ b/R/functions.R @@ -36,40 +36,50 @@ getLTSForRoute <- function(i, route_table) { 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,] + if(is.na(route$messages)){ + return(NA) + } + + text <- 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) + names.vec <- m[1,] + + if(nrow(m) == 2){ + df <- data.frame(t(m[-1,])) + }else{ + df <- data.frame(m[-1,]) + } + + names(df) <- names.vec + + 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) + }) -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)) -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)) + df2 <- df2 %>% filter(!is.na(highway)) if(!("cycleway" %in% df2$highway)){ diff --git a/WI-schools-cycle.Rmd b/WI-schools-cycle.Rmd index de4c0b7..5e75b19 100644 --- a/WI-schools-cycle.Rmd +++ b/WI-schools-cycle.Rmd @@ -34,7 +34,9 @@ set.seed(1) source("./R/functions.R") runLoop <- TRUE ``` + ## Configuration + ```{r config, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} options(osrm.server = "http://127.0.0.1:5001/") options(osrm.profile = "bike") @@ -43,9 +45,18 @@ 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 <- WI_schools %>% mutate(geom = SHAPE) +``` + +## 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. + ## Loop through WI Schools + ```{r mainloop, eval = runLoop, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = TRUE} radius <- 3 # miles levels <- c(1) @@ -56,6 +67,9 @@ gridList <- list() routesList <- list() indexVec <- 1:nrow(WI_schools) +#indexVec <- 1:50 +jj <- 1; +bad.school.vec <- c() for(j in indexVec){ @@ -91,7 +105,6 @@ for(j in indexVec){ if( response$status_code == "200" ){ route_run <- st_read(content <- content(response, as = "text"), quiet = TRUE) - route_run[["student_number"]] <- i routes[[i]] <- route_run }else{ routes[[i]] <- NA @@ -102,26 +115,60 @@ for(j in indexVec){ if(length(bad.cell) > 0){ routes <- routes[-bad.cell] - grid <- grid[-bad.cell] + grid <- grid[-bad.cell,] } - if(length(routes) > 0){ routes <- st_transform(bind_rows(routes), crs = 4326) + gridList[[jj]] <- grid + routesList[[jj]] <- routes + jj <- jj + 1 }else{ routes <- NA + bad.school.vec <- c(j, bad.school.vec) + cat( WI_schools$SCHOOL[j], "has zero routes to school and has been removed from analysis.\n") } - gridList[[j]] <- grid - routesList[[j]] <- routes - } +WI_schools <- WI_schools[-bad.school.vec,] + +saveRDS(WI_schools, "./R/data/WI_schools.rds") saveRDS(gridList, "./R/data/gridList.rds") saveRDS(routesList, "./R/data/routesList.rds") ``` +```{r showLists, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE} +routesList <- readRDS(file = "./R/data/routesList.rds") +gridList <- readRDS(file = "./R/data/gridList.rds") +not.cycleway.vec <- c() + +for(j in 1:length(gridList)){ + + grid <- gridList[[j]] + routes <- routesList[[j]] + + total.time.vec <- routes %>% pull(total.time) + grid <- cbind(grid, total.time = as.numeric(total.time.vec)) + + x.vec <- c() + for( i in 1:nrow(grid) ){ + route <- routes[i,"messages"] # Grid cell i to school j + x <- routeChar(route) + x.vec <- c(x.vec, x) + } + + grid <- cbind(grid, T.cycleway = x.vec) + grid <- cbind( grid, not.cycleway = (grid$total.time - grid$T.cycleway)/60) + gridList[[j]] <- grid + + not.cycleway.vec <- c(not.cycleway.vec, median(grid$not.cycleway)) + +} + +ggplot(data.frame(not.cycleway = not.cycleway.vec), aes(not.cycleway)) + geom_histogram(fill = "grey", color = "black") + theme_bw() +``` # Archive