7d7a980400
This script loops through WI schools and computes the cycling route from each grid cell to school. These routes and grids are saved to rds objects to be analyzed in a separate script.
132 lines
3.5 KiB
Plaintext
132 lines
3.5 KiB
Plaintext
---
|
|
title: "Wisconsin Cycling to School"
|
|
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 = 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)
|
|
fig.height <- 6
|
|
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")
|
|
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 <- WI_schools %>% mutate(geom = SHAPE)
|
|
WI_schools <- subset(WI_schools, !is.na(LAT) & !is.na(LON) & GRADE_RANGE == "09-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)
|
|
res <- 100
|
|
threshold <- units::set_units(1, km^2)
|
|
|
|
gridList <- list()
|
|
routesList <- list()
|
|
|
|
indexVec <- 1:nrow(WI_schools)
|
|
|
|
for(j in indexVec){
|
|
|
|
school_location <- WI_schools[j,]
|
|
|
|
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)
|
|
|
|
cellsize <- 1e-2
|
|
grid <- st_make_grid(cycle_boundary_poly, cellsize = cellsize, what = "polygons", square = FALSE)
|
|
grid <- st_intersection(cycle_boundary_poly, grid)
|
|
|
|
grid <- st_make_valid(grid)
|
|
|
|
grid_pts <- st_centroid(grid)
|
|
|
|
grid_coods <- st_coordinates(grid_pts)
|
|
school_focus_location <- school_location %>% 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)
|
|
|
|
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
|
|
}
|
|
}
|
|
|
|
bad.cell <- which(is.na(routes))
|
|
|
|
if(length(bad.cell) > 0){
|
|
routes <- routes[-bad.cell]
|
|
grid <- grid[-bad.cell]
|
|
}
|
|
|
|
|
|
if(length(routes) > 0){
|
|
routes <- st_transform(bind_rows(routes), crs = 4326)
|
|
}else{
|
|
routes <- NA
|
|
}
|
|
|
|
gridList[[j]] <- grid
|
|
routesList[[j]] <- routes
|
|
|
|
}
|
|
|
|
saveRDS(gridList, "./R/data/gridList.rds")
|
|
saveRDS(routesList, "./R/data/routesList.rds")
|
|
```
|
|
|
|
|
|
|
|
# Archive
|
|
|
|
```{r chunklast, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE}
|
|
date()
|
|
sessionInfo()
|
|
```
|