diff --git a/.gitignore b/.gitignore index da4a557..4838c57 100644 --- a/.gitignore +++ b/.gitignore @@ -15,8 +15,8 @@ data data-bkup/ data-bkup *.R +!R/functions.R *.bak -archive/ trash/ api_key R/route_analysis.html diff --git a/Makefile b/Makefile index df59fdb..ee206b4 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/R/functions.R b/R/functions.R new file mode 100644 index 0000000..c24604a --- /dev/null +++ b/R/functions.R @@ -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) +} diff --git a/cycling_route_analysis.Rmd b/archive/cycling_route_analysis.Rmd similarity index 99% rename from cycling_route_analysis.Rmd rename to archive/cycling_route_analysis.Rmd index 7116a91..b16f73c 100644 --- a/cycling_route_analysis.Rmd +++ b/archive/cycling_route_analysis.Rmd @@ -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() diff --git a/cycling_route_analysis_brouter.Rmd b/cycling_route_analysis_brouter.Rmd index feff52c..8934fad 100644 --- a/cycling_route_analysis_brouter.Rmd +++ b/cycling_route_analysis_brouter.Rmd @@ -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’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)) + +``` diff --git a/docker/.gitignore b/docker/.gitignore new file mode 100644 index 0000000..8b77f12 --- /dev/null +++ b/docker/.gitignore @@ -0,0 +1 @@ +archive/ \ No newline at end of file