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

Organized cycle_route_analysis_brouter.Rmd

Browse Source 
Added some notes. Divided up some chunks.
This commit is contained in:
syounkin 2024-11-07 12:43:30 -06:00
parent 34fa374de5
commit 41d87517d8
1 changed files with 49 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
cycling_route_analysis_brouter.Rmd
View File

@ -174,6 +174,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}
@ -187,56 +190,21 @@ 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&rsquo;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 functions, eval = runTLS, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
source("./R/functions.R")
```
```{r routeslts, eval = runTLS, echo = FALSE, 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)
}
# 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,
mc.cores = detectCores() / 2,
@ -244,16 +212,16 @@ 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()
```{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,
@ -272,8 +240,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
@ -494,3 +460,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))
```