Merge pull request #72 from U-Shift/development

Consolidation

Author: gmatosferreira

NAMESPACE

@@ -8,6 +8,7 @@ export(filter_by_agency)
 export(filter_by_modes)
 export(filter_by_route_name)
 export(get_network_extension)
+export(get_prioritization_stats)
 export(get_route_frequency_hourly)
 export(get_stop_frequency_hourly)
 export(get_way_frequency_hourly)

R/get_network_extension.R

@@ -18,8 +18,8 @@
 #'
 #' @examples
 #' \dontrun{
-#' gtfs = GTFShift::load_feed("gtfs.zip")
-#' route_extension = GTFShift::get_network_extension(gtfs)
+#' gtfs <- GTFShift::load_feed("gtfs.zip")
+#' route_extension <- GTFShift::get_network_extension(gtfs)
 #' }
 #'
 #' @seealso [GTFShift::get_route_frequency_hourly()]
@@ -29,38 +29,37 @@
 #'
 #' @export
 get_network_extension <- function(
-    gtfs,
-    route_identifier = "route_id",
-    direction_wise = TRUE,
-    unified = FALSE,
-    date = GTFShift::calendar_nextBusinessWednesday(),
-    use_osm_routes = NA
+  gtfs,
+  route_identifier = "route_id",
+  direction_wise = TRUE,
+  unified = FALSE,
+  date = GTFShift::calendar_nextBusinessWednesday(),
+  use_osm_routes = NA
 ) {
-
   # 0. Validations
   if (!(route_identifier %in% c("route_id", "route_short_name", "route_long_name"))) {
     stop("route_identifier should be one of: route_id, route_short_name or route_long_name")
   }
 
   # Compute hourly frequencies for each route
-  network = gtfs |> GTFShift::get_route_frequency_hourly(date = date, use_osm_routes = use_osm_routes, overline = FALSE)
+  network <- gtfs |> GTFShift::get_route_frequency_hourly(date = date, use_osm_routes = use_osm_routes, overline = FALSE)
 
   # Get unique shapes
-  shapes_unique = network |>
+  shapes_unique <- network |>
     st_drop_geometry() |>
     select(shape_id) |>
     distinct() |>
-    left_join(network, by = "shape_id", multiple="first")
+    left_join(network, by = "shape_id", multiple = "first")
 
   # Compute daily frequencies per route shape
-  network_redux = network |>
+  network_redux <- network |>
     st_drop_geometry() |>
     group_by(.data[[route_identifier]], direction_id, shape_id) |>
     summarise(frequency_day = sum(frequency)) |>
     ungroup()
 
   # Get shape with max frequencies per route
-  network_redux_max = network_redux |>
+  network_redux_max <- network_redux |>
     # Get max frequency shape per route (and direction, if direction_wise=TRUE)
     group_by(.data[[route_identifier]], shape_id, !!!if (direction_wise) rlang::syms("direction_id")) |>
     summarise(frequency_max = max(frequency_day)) |>
@@ -73,19 +72,21 @@ get_network_extension <- function(
     ungroup()
 
   # Join with the original network to get the shapes and compute its distance
-  network_redux_shapes = network_redux_max |>
+  network_redux_shapes <- network_redux_max |>
     left_join(shapes_unique, by = "shape_id") |>
     st_as_sf() |>
-    st_transform(crs = 3857) |> # For units in meters
-    mutate(length = st_length(geometry))
+    st_transform(crs = 3857) # For units in meters
+
+  geom_col <- st_geometry(network_redux_shapes)
+  network_redux_shapes <- network_redux_shapes |> mutate(length = st_length(geom_col))
 
   # Compute unified network extension
   if (unified) {
-    network_union = network_redux_shapes |>
+    network_union <- network_redux_shapes |>
       st_union() |>
       stplanr::line_cast() |>
       st_as_sf() |>
-      mutate(length = st_length(x))
+      mutate(length = st_length(geom_col))
     return(sum(network_union$length))
   }
 

R/get_prioritization_stats.R

@@ -0,0 +1,67 @@
+#' Get prioritization stats
+#'
+#' Get statistics about lane prioritization
+#'
+#' @param lane_prioritization sf data.frame. Lane prioritization.
+#' @param weight Character. Weight to use for weighted mean. Accepted values: "length", "frequency".
+#'
+#' @returns List with statistics about lane prioritization, with the following attributes:
+#' \describe{
+#'   \item{extension}{Total length of the prioritized network, in meters.}
+#'   \item{extension_bus_lane}{Total length of the bus lane segments, in meters.}
+#'   \item{speed_avg}{Average speed of the prioritized network, in km/h.}
+#'   \item{speed_min}{Minimum speed of the prioritized network, in km/h.}
+#'   \item{speed_max}{Maximum speed of the prioritized network, in km/h.}
+#'   \item{n_lanes_avg}{Average number of lanes in the prioritized network.}
+#'   \item{n_lanes_min}{Minimum number of lanes in the prioritized network.}
+#'   \item{n_lanes_max}{Maximum number of lanes in the prioritized network.}
+#' }
+#'
+#' @examples
+#' \dontrun{
+#' lane_prioritization <- GTFShift::prioritize_lanes(gtfs, q)
+#' stats <- GTFShift::get_prioritization_stats(lane_prioritization)
+#' }
+#'
+#' @import dplyr
+#' @import sf
+#'
+#' @export
+get_prioritization_stats <- function(
+  lane_prioritization,
+  weight = c("length", "frequency")
+) {
+    weight <- match.arg(weight)
+    prioritization_internal <- lane_prioritization |>
+        st_as_sf() |>
+        st_transform(crs = 3857)
+
+    geom_col <- st_geometry(prioritization_internal)
+    prioritization_internal <- prioritization_internal |>
+        mutate(
+            length = units::drop_units(st_length(geom_col))
+        ) |>
+        st_drop_geometry()
+    stats <- list()
+
+    # Compute bus lane extension
+    stats$extension <- sum(prioritization_internal$length, na.rm = TRUE)
+    stats$extension_bus_lane <- sum(
+        prioritization_internal |> filter(is_bus_lane) |> pull(length),
+        na.rm = TRUE
+    )
+
+    # Compute average speed, weighted by chosen weight
+    if ("speed_avg" %in% names(prioritization_internal)) {
+        stats$speed_avg <- weighted.mean(prioritization_internal$speed_avg, prioritization_internal[[weight]], na.rm = TRUE)
+        stats$speed_min <- min(prioritization_internal$speed_avg, na.rm = TRUE)
+        stats$speed_max <- max(prioritization_internal$speed_avg, na.rm = TRUE)
+    }
+
+    # Compute number of lanes, weighted by chosen weight
+    stats$n_lanes_avg <- weighted.mean(prioritization_internal$n_lanes, prioritization_internal[[weight]], na.rm = TRUE)
+    stats$n_lanes_min <- min(prioritization_internal$n_lanes, na.rm = TRUE)
+    stats$n_lanes_max <- max(prioritization_internal$n_lanes, na.rm = TRUE)
+
+    return(stats)
+}

R/load_feed.R

@@ -6,6 +6,7 @@
 #' @param transfer_distance Integer (Default 300). Upper straight-line distance limit in meters for transfers.
 #' @param transfer_time Integer (Default 120). Minimum time in seconds for transfers; all values below this will be replaced with this value, particularly all those defining in-place transfers where stop longitudes and latitudes remain identical.
 #' @param transfer_street_routing Boolean (Default FALSE). If TRUE, transfer times are calculated by routing throughout the underlying street network (downloaded automatically).
+#' @param headers Named list or character vector (Optional). Custom HTTP headers for credentials when accessing the GTFS zip file URL.
 #'
 #' @details
 #' In addition to loading the GTFS feed, this method validates its integrity and applies the proper corrections if it does not comply with the following validations:
@@ -32,7 +33,15 @@
 #' @import tidytransit
 #'
 #' @export
-load_feed <- function(path, store_path=NA, create_transfers=TRUE, transfer_distance=300, transfer_time=120, transfer_street_routing=FALSE) {
+load_feed <- function(path, store_path=NA, create_transfers=TRUE, transfer_distance=300, transfer_time=120, transfer_street_routing=FALSE, headers=NULL) {
+
+  # If path is a URL and headers are provided, download first
+  if (grepl("^http", path) && !is.null(headers)) {
+    temp_zip <- tempfile(fileext = ".zip")
+    res <- httr::GET(path, httr::add_headers(.headers = headers), httr::write_disk(temp_zip, overwrite = TRUE))
+    httr::stop_for_status(res)
+    path <- temp_zip
+  }
 
   # LOAD GTFS
   gtfs <- tidytransit::read_gtfs(path)

R/osm_utils.R

@@ -0,0 +1,23 @@
+#' Filter OpenStreetMap ways by bus lane tags
+#'
+#' @param road_osm sf object. Road OSM data.
+#'
+#' @return sf object. Filtered road OSM data.
+#'
+#' @import dplyr
+#'
+#' @noRd
+filter_osm_bus_lanes <- function(road_osm) {
+  cols_to_check_access <- grep("psv:lanes|bus:lanes", names(road_osm), value = TRUE)
+  cols_to_check_count <- grep("lanes:psv|lanes:bus", names(road_osm), value = TRUE)
+
+  osm_lanes <- road_osm |> filter(
+    # Based on https://wiki.openstreetmap.org/wiki/Bus_lanes
+    psv == "designated" |
+      highway == "busway" |
+      (length(cols_to_check_access) & if_any(all_of(cols_to_check_access), ~ grepl("designated", .x))) |
+      (length(cols_to_check_count) & if_any(all_of(cols_to_check_count), ~ is.numeric(.x) & .x >= 1))
+  )
+
+  return(osm_lanes)
+}

R/prioritize_lanes.R

@@ -37,65 +37,67 @@
 #'
 #' @examples
 #' \dontrun{
-#' gtfs = GTFShift::load_feed("gtfs.zip")
-#' q = opq(bbox=sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> add_osm_feature(key = "route", value = "bus")
-#' lanes_analysis = GTFShift::prioritize_lanes(gtfs, q)
+#' gtfs <- GTFShift::load_feed("gtfs.zip")
+#' q <- opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> add_osm_feature(key = "route", value = "bus")
+#' lanes_analysis <- GTFShift::prioritize_lanes(gtfs, q)
 #' }
 #'
 #' @import dplyr
 #' @import tidytransit
 #'
 #' @export
 prioritize_lanes <- function(
-    gtfs,
-    q,
-    date = GTFShift::calendar_nextBusinessWednesday(),
-    keep_osm_attributes = FALSE
+  gtfs,
+  q,
+  date = GTFShift::calendar_nextBusinessWednesday(),
+  keep_osm_attributes = FALSE
 ) {
-
   # Get way frequency hourly
-  way_frequency = GTFShift::get_way_frequency_hourly(gtfs, q, date, TRUE)
+  way_frequency <- GTFShift::get_way_frequency_hourly(gtfs, q, date, TRUE)
 
   # Get bus lanes
-  shapes_sf = tidytransit::shapes_as_sf(gtfs$shapes)
-  shapes_bbox = sf::st_bbox(shapes_sf)
-  bus_lanes = GTFShift::osm_bus_lanes(shapes_bbox)
+  bus_lanes <- filter_osm_bus_lanes(way_frequency |> distinct(way_osm_id, .keep_all = TRUE))
 
   # Aggregate data
   # > Add missing lanes columns, to prevent errors
-  lane_cols = c("lanes", "lanes:forward", "lanes:backward", "lanes:both_ways", "oneway")
+  lane_cols <- c("lanes", "lanes:forward", "lanes:backward", "lanes:both_ways", "oneway")
   for (col in lane_cols) {
     if (!(col %in% colnames(way_frequency))) {
-      way_frequency[[col]] = NA_character_
+      way_frequency[[col]] <- NA_character_
     }
   }
   parse_lanes <- function(x) {
     suppressWarnings(as.numeric(sub(";.*$", "", x)))
   }
 
   # > Compute aggregation
-  lanes = way_frequency |>
-    left_join(bus_lanes |> sf::st_drop_geometry() |> select(osm_id) |> mutate(is_bus_lane = TRUE), by = c("way_osm_id" = "osm_id")) |>
+  lanes <- way_frequency |>
+    left_join(bus_lanes |> st_drop_geometry() |> select(way_osm_id) |> mutate(is_bus_lane = TRUE), by = "way_osm_id") |>
     mutate(
       is_bus_lane = ifelse(is.na(is_bus_lane), FALSE, is_bus_lane),
       n_lanes_parking = dplyr::case_when(
         # Any 'parking:both' or 'parking:lane:both' column present with value different from 'no'
-        if_any(starts_with("parking:both"), ~ !is.na(.) & . != "no") ~ 2L,
-        # Otherwise, count left and right sides separately based on specific tags
+        if_any(matches("^parking(:lane)?:both"), ~ !is.na(.) & . != "no") ~ 2L,
+        # Otherwise, count left and right sides separately based on specific tags (parking:lane:left/right or parking:left/right)
         TRUE ~ (
           as.integer(
-            if_any(starts_with("parking:left"),~ !is.na(.) & . != "no")
+            if_any(matches("^parking(:lane)?:left"), ~ !is.na(.) & . != "no")
           ) +
-          as.integer(
-            if_any(starts_with("parking:right"), ~ !is.na(.) & . != "no")
-          )
+            as.integer(
+              if_any(matches("^parking(:lane)?:right"), ~ !is.na(.) & . != "no")
+            )
         )
       ),
       n_lanes_circulation = coalesce(
         # Global count
         parse_lanes(lanes),
-        # Directional count
-        parse_lanes(`lanes:forward`) + parse_lanes(`lanes:backward`) + parse_lanes(`lanes:both_ways`),
+        # Directional count (sum existing ones; returns NA if all are missing)
+        na_if(
+          coalesce(parse_lanes(`lanes:forward`), 0) +
+            coalesce(parse_lanes(`lanes:backward`), 0) +
+            coalesce(parse_lanes(`lanes:both_ways`), 0),
+          0
+        ),
         # If oneway=="yes", then 1
         ifelse(oneway == "yes", 1, NA_integer_),
         # Else, assume 2 lanes, one per direction
@@ -121,7 +123,7 @@ prioritize_lanes <- function(
     )
 
   if (!keep_osm_attributes) {
-    lanes = lanes |>
+    lanes <- lanes |>
       select(way_osm_id, hour, frequency, is_bus_lane, n_lanes_parking, n_lanes_circulation, n_lanes, n_directions, n_lanes_circulation_direction, n_lanes_direction, routes, shapes, geometry)
   }
 

R/query_osm_bus_lanes.R

@@ -11,7 +11,7 @@
 #'
 #' @examples
 #' \dontrun{
-#' BBOX = sf::st_bbox(city_limit)
+#' BBOX <- sf::st_bbox(city_limit)
 #' bus_lanes <- GTFShift::osm_bus_lanes(BBOX)
 #' }
 #'
@@ -21,24 +21,14 @@
 #'
 #' @export
 osm_bus_lanes <- function(bbox) {
-
-  road_osm = road_osm = opq(bbox) |> # uses osmdata package, to extract only with BB
+  road_osm <- opq(bbox) |> # uses osmdata package, to extract only with BB
     add_osm_feature(key = "highway") |>
     osmdata_sf() |>
     osm_poly2line() # makes roundabouts into lines
 
-  road_osm = road_osm$osm_lines
-
-  cols_to_check_access <- grep("psv:lanes|bus:lanes", names(road_osm), value = TRUE)
-  cols_to_check_count <- grep("lanes:psv|lanes:bus", names(road_osm), value = TRUE)
+  road_osm <- road_osm$osm_lines
 
-  osm_lanes = road_osm |> filter(
-    # Based on https://wiki.openstreetmap.org/wiki/Bus_lanes
-    psv == "designated"
-    | highway == "busway"
-    | (length(cols_to_check_access) & if_any(all_of(cols_to_check_access), ~ grepl("designated", .x)))
-    | (length(cols_to_check_count) & if_any(all_of(cols_to_check_count), ~ is.numeric(.x) & .x >= 1))
-  )
+  osm_lanes <- filter_osm_bus_lanes(road_osm)
 
   return(osm_lanes)
 }