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

edited routelts and new map of routes

Browse Source
This commit is contained in:
Ben Varick 2024-11-06 14:48:37 -06:00
parent e6614977c3
commit 21905af23a
No known key found for this signature in database
1 changed files with 38 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
cycling_route_analysis_brouter.Rmd
View File

@ -166,17 +166,17 @@ Notes:
```{r ltscount, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} ```{r ltscount, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
# Count the routes that intersect or overlap with each segment of the bike_tls network. # Count the routes that intersect or overlap with each segment of the bike_tls network.
# The intersections have a buffer of 20m # The intersections have a buffer of 10m
bike_lts_buffer <- st_buffer(st_intersection(bike_lts, cycle_boundary_poly), 20) bike_lts_buffer <- st_buffer(st_intersection(bike_lts, cycle_boundary_poly), 10)
bike_lts_buffer["student_use"] <- unlist(lapply(st_intersects(bike_lts_buffer, routes), length)) bike_lts_buffer["student_use"] <- unlist(lapply(st_intersects(bike_lts_buffer, routes), length))
bike_lts <- left_join(bike_lts, as.data.frame(bike_lts_buffer %>% select(OBJECTID, student_use)), by = "OBJECTID") 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 20 m buffer) Notes: for each segment in bike_lts, this counts how many student's calculated routes intersect with it (within a 10 m buffer)
```{r routeslts, eval = FALSE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} ```{r routeslts, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
getLTSForRoute <- function(i) { getLTSForRoute <- function(i) {
# Filter the routes for the current student number # Filter the routes for the current student number
@ -194,8 +194,8 @@ getLTSForRoute <- function(i) {
# calculate segment length in meters # calculate segment length in meters
current_route_lts_intersection$"segment_length" <- as.double(st_length(current_route_lts_intersection)) current_route_lts_intersection$"segment_length" <- as.double(st_length(current_route_lts_intersection))
# Return the result as a data frame # Return the result as a list
result <- data.frame( result <- list(
student_number = i student_number = i
, lts_max = max(current_route_lts_intersection$LTS_F) , 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_average = weighted.mean(current_route_lts_intersection$LTS_F, current_route_lts_intersection$segment_length)
@ -206,7 +206,7 @@ getLTSForRoute <- function(i) {
, route = as.data.frame(current_route_lts_intersection) , route = as.data.frame(current_route_lts_intersection)
) )
# Optional message for debugging/progress # Message for progress
message(paste0("done - ", i)) message(paste0("done - ", i))
return(result) return(result)
@ -218,11 +218,11 @@ routes_lts <- list(NULL)
# Pre-filter the bike_lts_buffer for relevant student use # Pre-filter the bike_lts_buffer for relevant student use
relevant_buffer <- bike_lts_buffer %>% filter(student_use > 0) relevant_buffer <- bike_lts_buffer %>% filter(student_use > 0)
routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)), # routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
getLTSForRoute) # getLTSForRoute)
system.time(routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)), # system.time(routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
getLTSForRoute)) # getLTSForRoute))
routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number), routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
getLTSForRoute, getLTSForRoute,
@ -241,9 +241,22 @@ routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
routes_lts <- bind_rows(routes_lts) routes_lts <- bind_rows(routes_lts)
ggmap(basemap) + geom_sf(data = routes_lts, inherit.aes = FALSE, aes(color = route.lts, geometry = routes_lts$route.geometry)) ggmap(basemap) +
geom_sf(data = routes_lts %>% filter(student_number == 6), inherit.aes = FALSE,
aes(color = route.lts,
geometry = route.geometry),
linewidth = 2) +
scale_color_manual(values = bike_lts_scale$color, name = "Bike Level of Traffic Stress")
addresses_near <- left_join(addresses_near, routes_lts, join_by("number"=="student_number")) # 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")),
join_by("number"=="student_number"),
multiple = "any")
# add supplemental analysis
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. 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.
@ -422,16 +435,15 @@ ggsave(file = paste0("figures/",
``` ```
## Generate map of addresses with LTS ## Generate map of routes with LTS
```{r mapaddresseslts, eval = FALSE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE} ```{r mapaddresseslts, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
# generate map # generate map
ggmap(basemap) + ggmap(basemap) +
labs(title = paste0("Level of Traffic stress for biking for students at ", labs(title = paste0("Level of Traffic stress for biking for students at ",
school_focus %>% pull(name)), school_focus %>% pull(name)),
subtitle = "only showing routes within the cycling boundary", subtitle = "only showing routes within the cycling boundary",
x = NULL, x = NULL,
y = NULL, y = NULL) +
color = "Average Bike Level of Traffic stress for route to school") +
theme(axis.text=element_blank(), theme(axis.text=element_blank(),
axis.ticks=element_blank(), axis.ticks=element_blank(),
plot.caption = element_text(color = "grey")) + plot.caption = element_text(color = "grey")) +
@ -442,10 +454,15 @@ ggmap(basemap) +
linewidth = 1) + linewidth = 1) +
scale_color_manual(values = "blue", name = NULL) + scale_color_manual(values = "blue", name = NULL) +
new_scale_color() + new_scale_color() +
geom_sf(data = addresses_near, geom_sf(data = routes_lts %>% filter(route$student_use >= 4),
inherit.aes = FALSE, inherit.aes = FALSE,
aes(color = lts_average)) + aes(geometry = route$geometry,
scale_color_gradientn(colors = bike_lts_scale$color, name = "Average Bike Level of Traffic Stress\nfor route from that address", limits = c(1,4)) + color = route$lts,
linewidth = route$student_use)) +
#scale_color_gradientn(colors = bike_lts_scale$color, name = "Length of high stress travel on route from that address", limits = c(1,4)) +
scale_color_manual(values = bike_lts_scale$color, name = "Bike Level of Traffic Stress") +
#scale_color_distiller(palette = "YlOrRd", direction = "reverse") +
scale_linewidth_continuous(range = c(0, 3)) +
annotation_raster(school_symbol, annotation_raster(school_symbol,
# Position adjustments here using plot_box$max/min/range # Position adjustments here using plot_box$max/min/range
ymin = as.double((WI_schools %>% filter(NCES_CODE %in% school_focus$NCES_CODE) %>% pull(geom))[[1]])[2] - 0.001, ymin = as.double((WI_schools %>% filter(NCES_CODE %in% school_focus$NCES_CODE) %>% pull(geom))[[1]])[2] - 0.001,
@ -461,7 +478,7 @@ ggmap(basemap) +
ggsave(file = paste0("figures/", ggsave(file = paste0("figures/",
school_focus %>% pull(name), school_focus %>% pull(name),
" Addresses - Traffic Stress_cycling.pdf"), " Routes - Traffic Stress_cycling_new.pdf"),
title = paste0(school_focus %>% pull(name), " Student Addresses - Cycling Traffic Stress"), title = paste0(school_focus %>% pull(name), " Student Addresses - Cycling Traffic Stress"),
device = pdf, device = pdf,
height = 8.5, height = 8.5,