diff --git a/cycling_route_analysis_brouter.Rmd b/cycling_route_analysis_brouter.Rmd index f39fb6f..da5407d 100644 --- a/cycling_route_analysis_brouter.Rmd +++ b/cycling_route_analysis_brouter.Rmd @@ -166,63 +166,29 @@ Notes: ```{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. -# The intersections have a buffer of 10m -bike_lts_buffer <- st_buffer(st_intersection(bike_lts, cycle_boundary_poly), 10) +# The intersections have a buffer of 20m +bike_lts_buffer <- st_buffer(st_intersection(bike_lts, cycle_boundary_poly), 20) 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") ``` -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's calculated routes intersect with it (within a 20 m buffer) -```{r routeslts, eval = TRUE, echo = TRUE, results = "show", warning = FALSE, error = TRUE, message = FALSE} +```{r routeslts, eval = FALSE, 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) + lts_segments <- (bike_lts_buffer %>% filter(student_use > 0))$OBJECTID[st_intersects(bike_lts_buffer %>% filter(student_use > 0), 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[[as.character(i)]] <- data.frame("student_number" = c(as.character(i)), "lts_max" = c(lts_max), "lts_average" = c(lts_average)) + return(data.frame("student_number" = i, "lts_max" = lts_max, "lts_average" = lts_average)) + message(paste0("done - ", i, " of ", max(addresses_near$number))) } -# 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)) +# getLTSForRoute) routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number), getLTSForRoute, @@ -241,22 +207,7 @@ routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number), routes_lts <- bind_rows(routes_lts) -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") - -# 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) +addresses_near <- left_join(addresses_near, routes_lts, join_by("number"=="student_number")) ``` 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. @@ -435,15 +386,16 @@ 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 addresses with LTS +```{r mapaddresseslts, eval = FALSE, 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 ", school_focus %>% pull(name)), subtitle = "only showing routes within the cycling boundary", x = NULL, - y = NULL) + + y = NULL, + color = "Average Bike Level of Traffic stress for route to school") + theme(axis.text=element_blank(), axis.ticks=element_blank(), plot.caption = element_text(color = "grey")) + @@ -454,15 +406,10 @@ ggmap(basemap) + linewidth = 1) + scale_color_manual(values = "blue", name = NULL) + new_scale_color() + - geom_sf(data = routes_lts %>% filter(route$student_use >= 4), + geom_sf(data = addresses_near, inherit.aes = FALSE, - aes(geometry = route$geometry, - 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)) + + aes(color = lts_average)) + + scale_color_gradientn(colors = bike_lts_scale$color, name = "Average Bike Level of Traffic Stress\nfor route from that address", limits = c(1,4)) + annotation_raster(school_symbol, # 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, @@ -478,7 +425,7 @@ ggmap(basemap) + ggsave(file = paste0("figures/", school_focus %>% pull(name), - " Routes - Traffic Stress_cycling_new.pdf"), + " Addresses - Traffic Stress_cycling.pdf"), title = paste0(school_focus %>% pull(name), " Student Addresses - Cycling Traffic Stress"), device = pdf, height = 8.5,