ben/route_analysis
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #16 from syounkin/sgy

Browse Source 
Created an archive directory
create R/function.R
organize cycle_route_analysis_brouter.Rmd
This commit is contained in:
bvarick 2024-11-07 14:06:52 -06:00 committed by GitHub
commit 42c7df44fe
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
6 changed files with 103 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -15,8 +15,8 @@ data
data-bkup/
data-bkup
*.R
!R/functions.R
*.bak
archive/
trash/
api_key
R/route_analysis.html

4
Makefile
View File

@ -29,10 +29,10 @@ brouter-container: ./docker/brouter/docker-compose.yml
cd ./docker/brouter; docker compose up -d
brouter-data:
cd ./docker/brouter/; rm -rf ./brouter; git clone https://github.com/abrensch/brouter.git
cd ./docker/brouter/; rm -rf ./brouter-bkup/; mv -v ./brouter/ ./brouter-bkup/; git clone https://github.com/abrensch/brouter.git
cd ./docker/brouter/; wget -i segments.csv -P ./brouter/misc/segments4/
cd ./docker/brouter/; cp safety.brf ./brouter/misc/profiles2/safety.brf
cd ./docker/brouter/; rm -rf ./brouter-web; git clone https://github.com/nrenner/brouter-web.git
cd ./docker/brouter/; rm -rf ./brouter-web-bkup/; mv -v ./brouter-web/ ./brouter-web-bkup/; git clone https://github.com/nrenner/brouter-web.git
cd ./docker/brouter/brouter-web; cp keys.template.js keys.js;
cd ./docker/brouter/brouter-web; cp config.template.js config.js
cd ./docker/brouter; docker compose build

34
R/functions.R Normal file
View File

@ -0,0 +1,34 @@
getLTSForRoute <- function(i) {
# Filter the routes for the current student number
current_route <- routes %>% filter(student_number == i)
# Find intersecting OBJECTIDs
intersecting_ids <- relevant_buffer$OBJECTID[lengths(st_intersects(relevant_buffer, current_route)) > 0]
# Filter relevant segments to calculate max and average lts
relevant_segments <- bike_lts_buffer %>% filter(OBJECTID %in% intersecting_ids)
# find all the segments of relevant_buffer that the current route passes through
current_route_lts_intersection <- st_intersection(current_route, relevant_segments)
# calculate segment length in meters
current_route_lts_intersection$"segment_length" <- as.double(st_length(current_route_lts_intersection))
# Return the result as a list
result <- list(
student_number = i
, lts_max = max(current_route_lts_intersection$LTS_F)
, lts_average = weighted.mean(current_route_lts_intersection$LTS_F, current_route_lts_intersection$segment_length)
, lts_1_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 1) %>% pull(LTS_F))
, lts_2_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 2) %>% pull(LTS_F))
, lts_3_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 3) %>% pull(LTS_F))
, lts_4_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 4) %>% pull(LTS_F))
, route = as.data.frame(current_route_lts_intersection)
)
# Message for progress
message(paste0("done - ", i))
return(result)
}

3
cycling_route_analysis.Rmd → archive/cycling_route_analysis.Rmd
View File

@ -16,6 +16,7 @@ editor_options:
## Libraries
```{r libs, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
#foo
date()
rm(list=ls())
library(tidyverse)
@ -328,6 +329,8 @@ ggsave(file = paste0("figures/",
# Appendix
This script has been moved to ./archive/.
```{r chunklast, eval = TRUE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE}
date()
sessionInfo()

140
cycling_route_analysis_brouter.Rmd
View File

@ -31,6 +31,9 @@ library(jsonlite)
library(parallel)
fig.height <- 6
set.seed(1)
runTLS <- TRUE
logo <- image_read(path = "other/BFW_Logo_180_x_200_transparent_background.png")
school_symbol <- image_read_svg(path = "other/school_FILL0_wght400_GRAD0_opsz24.svg")
```
## School Location Data
@ -138,10 +141,10 @@ routes <- list(NULL)
school_focus_location <- WI_schools %>% filter(NCES_CODE %in% school_focus$NCES_CODE) %>% select(LAT, LON)
for(i in addresses_near %>% arrange(number) %>% pull(number)) {
query <- paste0(
brouter_url,
brouter_url,
"?lonlats=",
(addresses_near %>% filter(number == i) %>% pull(point) %>% str_split(., ","))[[1]][1], ",",
(addresses_near %>% filter(number == i) %>% pull(point) %>% str_split(., ","))[[1]][2], "|",
(addresses_near %>% filter(number == i) %>% pull(point) %>% str_split(., ","))[[1]][1], ",",
(addresses_near %>% filter(number == i) %>% pull(point) %>% str_split(., ","))[[1]][2], "|",
school_focus_location$LON, ",", school_focus_location$LAT,
"&profile=", brouter_profile,
"&alternativeidx=0&format=geojson"
@ -150,8 +153,8 @@ for(i in addresses_near %>% arrange(number) %>% pull(number)) {
route_run <- st_read(content <- content(response, as = "text"), quiet = TRUE)
route_run[["student_number"]] <- i
routes[[i]] <- route_run
message(paste0("done - ", i, " of ", max(addresses_near$number)))
}
@ -173,6 +176,9 @@ bbox <- c(left = as.double(bbox[1]),
#get basemap
basemap <- get_stadiamap(bbox = bbox, zoom = 15, maptype = "stamen_toner_lite")
```
Notes:
- This chunk retrieves the base map from Stadia Maps (API key required)
## Combine routes with Bike LTS
```{r ltscount, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
@ -186,55 +192,20 @@ bike_lts_buffer["student_use"] <- unlist(lapply(st_intersects(bike_lts_buffer, r
bike_lts <- left_join(bike_lts, as.data.frame(bike_lts_buffer %>% select(OBJECTID, student_use)), by = "OBJECTID")
```
Notes: for each segment in bike_lts, this counts how many student's calculated routes intersect with it (within a 10 m buffer)
Notes:
- for each segment in bike_lts, this counts how many student&rsquo;s
calculated routes intersect with it (within a 10 m buffer)
```{r routeslts, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
getLTSForRoute <- function(i) {
# Filter the routes for the current student number
current_route <- routes %>% filter(student_number == i)
# Find intersecting OBJECTIDs
intersecting_ids <- relevant_buffer$OBJECTID[lengths(st_intersects(relevant_buffer, current_route)) > 0]
# Filter relevant segments to calculate max and average lts
relevant_segments <- bike_lts_buffer %>% filter(OBJECTID %in% intersecting_ids)
# find all the segments of relevant_buffer that the current route passes through
current_route_lts_intersection <- st_intersection(current_route, relevant_segments)
# calculate segment length in meters
current_route_lts_intersection$"segment_length" <- as.double(st_length(current_route_lts_intersection))
# Return the result as a list
result <- list(
student_number = i
, lts_max = max(current_route_lts_intersection$LTS_F)
, lts_average = weighted.mean(current_route_lts_intersection$LTS_F, current_route_lts_intersection$segment_length)
, lts_1_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 1) %>% pull(LTS_F))
, lts_2_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 2) %>% pull(LTS_F))
, lts_3_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 3) %>% pull(LTS_F))
, lts_4_dist = sum(current_route_lts_intersection %>% filter(LTS_F == 4) %>% pull(LTS_F))
, route = as.data.frame(current_route_lts_intersection)
)
# Message for progress
message(paste0("done - ", i))
return(result)
}
```{r functions, eval = runTLS, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
source("./R/functions.R")
```
```{r routeslts, eval = runTLS, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
# Start with routes_lts as a NULL list
routes_lts <- list(NULL)
# Pre-filter the bike_lts_buffer for relevant student use
relevant_buffer <- bike_lts_buffer %>% filter(student_use > 0)
# routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
# getLTSForRoute)
# system.time(routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
# getLTSForRoute))
routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
getLTSForRoute,
@ -243,27 +214,32 @@ routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
mc.preschedule = TRUE,
mc.silent = FALSE)
# for(i in addresses_near %>% arrange(number) %>% pull(number)) {
# lts_segments <- bike_lts_buffer$OBJECTID[st_intersects(bike_lts_buffer, routes %>% filter(student_number == i), sparse = FALSE)]
# lts_max <- max(bike_lts_buffer %>% filter(OBJECTID %in% lts_segments) %>% pull(LTS_F), na.rm = TRUE)
# lts_average <- mean(bike_lts_buffer %>% filter(OBJECTID %in% lts_segments) %>% pull(LTS_F), na.rm = TRUE)
# routes_lts[[i]] <- data.frame("student_number" = c(i), "lts_max" = c(lts_max), "lts_average" = c(lts_average))
# message(paste0("done - ", i, " of ", max(addresses_near$number)))
# }
routes_lts <- bind_rows(routes_lts)
```
Notes:
- for each student's route, this finds which bike_lts segment it
intersects with and calculates a max and an average level of traffic
stress (LTS). This takes a while, so a parallelized it. There's
probably a more efficient way to do this calculation.
- see ./R/functions.R for defintion of getLTSForRoute()
ggmap(basemap) +
geom_sf(data = routes_lts %>% filter(student_number == 6), inherit.aes = FALSE,
aes(color = route$lts,
# Make Maps
## Generate map with LTS data
```{r maplts, eval = runTLS, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
ggmap(basemap) +
geom_sf(data = routes_lts %>% filter(student_number == 6), inherit.aes = FALSE,
aes(color = route$lts,
geometry = route$geometry),
linewidth = 2) +
linewidth = 2) +
scale_color_manual(values = bike_lts_scale$color, name = "Bike Level of Traffic Stress")
# Join the data with the addresses data
addresses_near <- left_join(addresses_near,
routes_lts %>%
select(c("student_number", "lts_max", "lts_average", "lts_1_dist", "lts_2_dist", "lts_3_dist", "lts_4_dist")),
addresses_near <- left_join(addresses_near,
routes_lts %>%
select(c("student_number", "lts_max", "lts_average", "lts_1_dist", "lts_2_dist", "lts_3_dist", "lts_4_dist")),
join_by("number"=="student_number"),
multiple = "any")
@ -271,18 +247,6 @@ addresses_near <- left_join(addresses_near,
addresses_near <- addresses_near %>% mutate(lts_34_dist = lts_3_dist + lts_4_dist)
```
Notes: for each student's route, this finds which bike_lts segment it intersects with and calculates a max and an average level of traffic stress (LTS). This takes a while, so a parallelized it. There's probably a more efficient way to do this calculation.
# Make Maps
## Load school and Bike Fed logo
```{r logos, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
# load logo
logo <- image_read(path = "other/BFW_Logo_180_x_200_transparent_background.png")
school_symbol <- image_read_svg(path = "other/school_FILL0_wght400_GRAD0_opsz24.svg")
```
## Generate map of addresses
```{r mapaddresses, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
@ -382,8 +346,8 @@ ggsave(file = paste0("figures/",
create.dir = TRUE)
```
## Generate map of routes with LTS
```{r maprouteslts, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
## Generate map of routes with LTS (1)
```{r maprouteslts, eval = runTLS, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
# generate map
ggmap(basemap) +
labs(title = paste0("Cycling routes for students at ",
@ -434,8 +398,9 @@ ggsave(file = paste0("figures/",
```
## Generate map of routes with LTS
```{r mapaddresseslts, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
## Generate map of routes with LTS (2)
```{r mapaddresseslts, eval = runTLS, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
# generate map
ggmap(basemap) +
labs(title = paste0("Level of Traffic stress for biking for students at ",
@ -493,3 +458,22 @@ ggsave(file = paste0("figures/",
date()
sessionInfo()
```
# Archive
```{r archive1, eval = FALSE, echo = TRUE, results = "show", warning = TRUE, error = TRUE, message = TRUE}
# for(i in addresses_near %>% arrange(number) %>% pull(number)) {
# lts_segments <- bike_lts_buffer$OBJECTID[st_intersects(bike_lts_buffer, routes %>% filter(student_number == i), sparse = FALSE)]
# lts_max <- max(bike_lts_buffer %>% filter(OBJECTID %in% lts_segments) %>% pull(LTS_F), na.rm = TRUE)
# lts_average <- mean(bike_lts_buffer %>% filter(OBJECTID %in% lts_segments) %>% pull(LTS_F), na.rm = TRUE)
# routes_lts[[i]] <- data.frame("student_number" = c(i), "lts_max" = c(lts_max), "lts_average" = c(lts_average))
# message(paste0("done - ", i, " of ", max(addresses_near$number)))
# }
# routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
# getLTSForRoute)
# system.time(routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
# getLTSForRoute))
```

1
docker/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
archive/