diff --git a/cycling_route_analysis_brouter.Rmd b/cycling_route_analysis_brouter.Rmd index bc840c3..b21ab1f 100644 --- a/cycling_route_analysis_brouter.Rmd +++ b/cycling_route_analysis_brouter.Rmd @@ -139,10 +139,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" @@ -151,8 +151,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))) } @@ -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,55 +190,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’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, @@ -244,27 +212,27 @@ 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, +```{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") @@ -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)) + +```