Compare commits
No commits in common. "21905af23aee631b1d56f542a65bd86cb5862c7c" and "4c98d5a68d6e77e149ddc6d22fa2d7297c0e3611" have entirely different histories.
21905af23a
...
4c98d5a68d
@ -166,63 +166,29 @@ 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 10m
|
# The intersections have a buffer of 20m
|
||||||
bike_lts_buffer <- st_buffer(st_intersection(bike_lts, cycle_boundary_poly), 10)
|
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_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 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) {
|
getLTSForRoute <- function(i) {
|
||||||
|
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)]
|
||||||
# Filter the routes for the current student number
|
lts_max <- max(bike_lts_buffer %>% filter(OBJECTID %in% lts_segments) %>% pull(LTS_F), na.rm = TRUE)
|
||||||
current_route <- routes %>% filter(student_number == i)
|
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))
|
||||||
# Find intersecting OBJECTIDs
|
return(data.frame("student_number" = i, "lts_max" = lts_max, "lts_average" = lts_average))
|
||||||
intersecting_ids <- relevant_buffer$OBJECTID[lengths(st_intersects(relevant_buffer, current_route)) > 0]
|
message(paste0("done - ", i, " of ", max(addresses_near$number)))
|
||||||
|
|
||||||
# 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)
|
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)),
|
# routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
|
||||||
# getLTSForRoute)
|
# getLTSForRoute)
|
||||||
|
|
||||||
# system.time(routes_lts <- lapply(head(addresses_near %>% arrange(number) %>% pull(number)),
|
|
||||||
# getLTSForRoute))
|
|
||||||
|
|
||||||
routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
|
routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
|
||||||
getLTSForRoute,
|
getLTSForRoute,
|
||||||
@ -241,22 +207,7 @@ routes_lts <- mclapply(addresses_near %>% arrange(number) %>% pull(number),
|
|||||||
|
|
||||||
routes_lts <- bind_rows(routes_lts)
|
routes_lts <- bind_rows(routes_lts)
|
||||||
|
|
||||||
ggmap(basemap) +
|
addresses_near <- left_join(addresses_near, routes_lts, join_by("number"=="student_number"))
|
||||||
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)
|
|
||||||
```
|
```
|
||||||
|
|
||||||
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.
|
||||||
@ -435,15 +386,16 @@ ggsave(file = paste0("figures/",
|
|||||||
|
|
||||||
```
|
```
|
||||||
|
|
||||||
## Generate map of routes with LTS
|
## Generate map of addresses with LTS
|
||||||
```{r mapaddresseslts, eval = TRUE, echo = FALSE, results = "show", warning = FALSE, error = TRUE, message = FALSE}
|
```{r mapaddresseslts, eval = FALSE, 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")) +
|
||||||
@ -454,15 +406,10 @@ 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 = routes_lts %>% filter(route$student_use >= 4),
|
geom_sf(data = addresses_near,
|
||||||
inherit.aes = FALSE,
|
inherit.aes = FALSE,
|
||||||
aes(geometry = route$geometry,
|
aes(color = lts_average)) +
|
||||||
color = route$lts,
|
scale_color_gradientn(colors = bike_lts_scale$color, name = "Average Bike Level of Traffic Stress\nfor route from that address", limits = c(1,4)) +
|
||||||
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,
|
||||||
@ -478,7 +425,7 @@ ggmap(basemap) +
|
|||||||
|
|
||||||
ggsave(file = paste0("figures/",
|
ggsave(file = paste0("figures/",
|
||||||
school_focus %>% pull(name),
|
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"),
|
title = paste0(school_focus %>% pull(name), " Student Addresses - Cycling Traffic Stress"),
|
||||||
device = pdf,
|
device = pdf,
|
||||||
height = 8.5,
|
height = 8.5,
|
||||||
|
Loading…
x
Reference in New Issue
Block a user