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

@@ -36,20 +36,30 @@ 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,]
 
-df2 <- within(df, {
+    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)
@@ -59,17 +69,17 @@ df2 <- within(df, {
         service <- grepl("highway=service", df$WayTags)
         cycleway <- grepl("highway=cycleway", df$WayTags)
         bike <- grepl("bicycle=designated", df$WayTags)
-})
+    })
 
 
-foo <- function(x){
+    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 <- 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)){

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