Organized cycle_route_analysis_brouter.Rmd

Added some notes. Divided up some chunks.

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]][1], ",",
-    (addresses_near %>% filter(number == i) %>% pull(point) %>% str_split(., ","))[[1]][2], "|", 
+    (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&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,
@@ -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) + 
+```{r maplts, eval = runTLS, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
-  geom_sf(data = routes_lts %>% filter(student_number == 6), inherit.aes = FALSE, 
+ggmap(basemap) +
-          aes(color = route$lts, 
+  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, 
+addresses_near <- left_join(addresses_near,
-                            routes_lts %>% 
+                            routes_lts %>%
-                              select(c("student_number", "lts_max", "lts_average", "lts_1_dist", "lts_2_dist", "lts_3_dist", "lts_4_dist")), 
+                              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))
+
+```