diff --git a/.RDataTmp b/.RDataTmp deleted file mode 100644 index a4233a47..00000000 Binary files a/.RDataTmp and /dev/null differ diff --git a/.Rbuildignore b/.Rbuildignore index d61beba7..b4685b75 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -5,4 +5,17 @@ ^pkgdown$ ^\.github$ ^vignettes/articles$ -^dev$ \ No newline at end of file +^dev$ +^releases$ +(^|/)venv(/.*)?$ +LICENSE.md +CITATION.cff +^doc$ +^Meta$ +^scratch$ +cache +(^|/)[^/]*cache[^/]*(/.*)?$ +^\.RDataTmp$ +^\.RData$ +^revdep$ +^cran-comments\.md$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 00000000..5478302a --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,75 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + +name: R-CMD-check.yaml + +permissions: read-all + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macos-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - name: Install osmium-tool (Linux) + if: runner.os == 'Linux' + run: sudo apt-get install -y osmium-tool + + - name: Install osmium-tool (macOS) + if: runner.os == 'macOS' + run: brew install osmium-tool + + - name: Setup Conda (Windows) + if: runner.os == 'Windows' + uses: conda-incubator/setup-miniconda@v3 + with: + channels: conda-forge + channel-priority: strict + + - name: Install osmium-tool (Windows) + if: runner.os == 'Windows' + shell: bash -el {0} + run: | + conda install -y osmium-tool + echo "$CONDA_PREFIX/Library/bin" >> $GITHUB_PATH + echo "$CONDA_PREFIX/Scripts" >> $GITHUB_PATH + echo "$CONDA_PREFIX" >> $GITHUB_PATH + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 27d3f20e..13258248 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -32,9 +32,21 @@ jobs: with: use-public-rspm: true + - name: Install osmium-tool (Linux) + run: sudo apt-get install -y osmium-tool + + - uses: actions/setup-python@v5 + with: + python-version: '3.11' + + - name: Install Python dependencies for neatnet (osm_centerlines) + run: | + python -m pip install --upgrade pip + pip install osmnx pandas geopandas shapely neatnet pyrosm + - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::pkgdown, local::. + extra-packages: any::pkgdown, any::rosmium, any::reticulate, local::. needs: website - name: Build site diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 00000000..87aa1d8e --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,105 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + pull_request: + branches: [main, master] + +name: test-coverage.yaml + +permissions: read-all + +jobs: + test-coverage: + runs-on: ubuntu-latest + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + MOBILITY_DATABASE: ${{ secrets.MOBILITY_DATABASE }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + # testthat and rosmium are Suggests (optional) in DESCRIPTION so they + # are not guaranteed to be installed automatically — list them explicitly. + extra-packages: any::covr, any::xml2, any::testthat, any::rosmium, local::. + needs: coverage + + - name: Run tests and compute coverage + run: | + install_path <- file.path( + normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package" + ) + + # Helper: print the .Rout.fail file so the actual test error is visible + # in the CI log instead of just a path reference. + dump_rout_fail <- function() { + fail_files <- list.files(install_path, pattern = "\\.Rout\\.fail$", + recursive = TRUE, full.names = TRUE) + if (length(fail_files) == 0) { + message("No .Rout.fail file found.") + return(invisible(NULL)) + } + for (f in fail_files) { + message("\n========== ", basename(f), " ==========") + cat(readLines(f, warn = FALSE), sep = "\n") + message("============================================\n") + } + } + + cov <- tryCatch( + covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = install_path + ), + error = function(e) { + message("\n--- Test suite failed. Dumping .Rout.fail for diagnosis ---\n") + dump_rout_fail() + stop(e) # re-throw so the job still fails + } + ) + + # Print summary to the log + print(cov) + + # Generate Cobertura XML report for Codecov upload + covr::to_cobertura(cov, filename = "coverage.xml") + + # Compute total coverage percentage and write to GITHUB_ENV + pct <- covr::percent_coverage(cov) + message("Total coverage: ", round(pct, 2), "%") + writeLines(paste0("COVERAGE_PCT=", round(pct, 2)), Sys.getenv("GITHUB_ENV")) + shell: Rscript {0} + + - name: Upload coverage to Codecov + uses: codecov/codecov-action@v4 + with: + files: coverage.xml + token: ${{ secrets.CODECOV_TOKEN }} + fail_ci_if_error: false # don't fail the PR if Codecov is unreachable + + - name: Upload Cobertura XML as workflow artifact + uses: actions/upload-artifact@v4 + with: + name: coverage-report + path: coverage.xml + + - name: Enforce minimum coverage threshold + run: | + pct <- as.numeric(Sys.getenv("COVERAGE_PCT")) + threshold <- 0 # Set your desired minimum coverage % here (e.g. 60) + if (!is.na(pct) && pct < threshold) { + stop(paste0( + "Coverage (", round(pct, 2), "%) is below the required threshold of ", + threshold, "%." + )) + } else { + message("Coverage check passed: ", round(pct, 2), "%") + } + shell: Rscript {0} diff --git a/.gitignore b/.gitignore index c8cf31d5..a6e7f081 100644 --- a/.gitignore +++ b/.gitignore @@ -1,15 +1,16 @@ .Rproj.user .Rhistory .RData +.RDataTmp .Ruserdata inst/doc docs -*.csv -*.gpkg -*.zip - releases/ vignettes/*_cache/* -scratch/* \ No newline at end of file +scratch/* +/doc/ +/Meta/ +*cache* +revdep/ diff --git a/DESCRIPTION b/DESCRIPTION index b8e80085..96f7444a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,47 +1,63 @@ -Package: GTFShift Type: Package -Title: Explore and Analyse General Transit Feed Specification (GTFS) Files With a Focus on Urban Mobility -Version: 0.11.0 +Package: GTFShift +Title: Explore and Analyse General Transit Feed Specification (GTFS) Files + with a Focus on Urban Mobility +Version: 0.12.0 Authors@R: c( - person(c("Gonçalo", "F."), "Matos", email = "goncaloafmatos@tecnico.pt", role = c("aut", "cre"), comment = c(ORCID = "0009-0001-3489-1732")), - person("Rosa", "Félix", email = "rosamfelix@tecnico.pt", role = c("aut"), comment = c(ORCID = "0000-0002-5642-6006"))) -Description: GTFShift emerged from the necessity to perform systematic analysis for academic research - over General Transit Feed Specification (GTFS) files that were not supported by any R library. It compiles - the methods developed for this purpose, aiming to contribute to an open source culture. - Its functionality is built mostly on [tidytransit](https://r-transit.github.io/tidytransit/) package. -License: GNU General Public License, Version 3 (GPL-3) -Encoding: UTF-8 + person(c("Gonçalo", "F."), "Matos", , "goncaloafmatos@tecnico.pt", role = c("aut", "cre"), + comment = c(ORCID = "0009-0001-3489-1732")), + person("Rosa", "Félix", , "rosamfelix@tecnico.pt", role = "aut", + comment = c(ORCID = "0000-0002-5642-6006")), + person("Miguel", "Relvas Pires", , "miguelpcrpires@tecnico.ulisboa.pt", role = "ctb") + ) +Description: This package encompasses a complete bundle of methods to + harmonize GTFS and OSM data, enabling the integration and exploration + of different layers of transit data, starting with the planned + operations (GTFS), but also the infrastructure topology (OSM) and + real-time information (GTFS-RT). +License: GPL +URL: https://github.com/U-Shift/GTFShift, + https://u-shift.github.io/GTFShift/ Depends: - R (>= 4.1.0) + R (>= 4.1.0) Imports: tidytransit, gtfstools, - zip, sf, - tidyverse, + tidyselect, + tidyr, lubridate, - gtfsrouter (>= 0.1.4), httr, jsonlite, dplyr, osmdata, - stplanr, stringr, - reticulate, - progress, callr, - stringi, - parallel -URL: https://github.com/U-Shift/GTFShift, https://u-shift.github.io/GTFShift/ + purrr, + rlang, + xml2, + withr Suggests: knitr, rmarkdown, mapview, - xml2, - RProtoBuf, osmextract, - rosmium -VignetteBuilder: knitr + rosmium, + testthat, + zip, + gtfsrouter (>= 0.1.4), + reticulate, + parallel, + RProtoBuf, + stplanr, + lwgeom, + progress, + stringi, + spelling +VignetteBuilder: + knitr Config/Needs/website: rmarkdown Config/roxygen2/version: 8.0.0 +Encoding: UTF-8 +Language: en-US RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 642cab27..27e4fef4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,7 +9,7 @@ export(filter_by_agency) export(filter_by_modes) export(filter_by_route_name) export(get_network_extension) -export(get_prioritization_stats) +export(get_prioritisation_stats) export(get_route_frequency_hourly) export(get_stop_frequency_hourly) export(get_way_frequency_hourly) @@ -20,35 +20,43 @@ export(osm_bus_lanes) export(osm_centerlines) export(osm_shapes_match_routes) export(osm_shapes_to_routes) -export(prioritize_lanes) +export(prioritise_lanes) export(project_points_along_geometry) export(query_mobilitydatabase) export(rt_average_speed) export(rt_collect_json) export(rt_collect_protobuf) -export(rt_extend_prioritization) +export(rt_extend_prioritisation) export(unify) -import(RProtoBuf) -import(callr) import(dplyr) -import(gtfstools) -import(httr) -import(jsonlite) import(lubridate) -import(lwgeom) import(osmdata) -import(parallel) -import(progress) -import(purrr) -import(reticulate) import(rlang) import(sf) -import(stplanr) -import(stringi) -import(stringr) import(tidytransit) -import(tidyverse) -import(xml2) -importFrom(gtfsrouter,extract_gtfs) -importFrom(gtfsrouter,gtfs_transfer_table) +importFrom(callr,r_bg) +importFrom(gtfstools,convert_sf_to_shapes) importFrom(gtfstools,merge_gtfs) +importFrom(httr,GET) +importFrom(httr,POST) +importFrom(httr,add_headers) +importFrom(httr,content) +importFrom(httr,http_error) +importFrom(httr,http_status) +importFrom(httr,status_code) +importFrom(jsonlite,fromJSON) +importFrom(jsonlite,write_json) +importFrom(purrr,map_dfr) +importFrom(rlang,.data) +importFrom(stats,setNames) +importFrom(stats,weighted.mean) +importFrom(stringr,regex) +importFrom(stringr,str_detect) +importFrom(tidyr,unnest) +importFrom(tidyselect,any_of) +importFrom(utils,head) +importFrom(utils,tail) +importFrom(utils,write.table) +importFrom(xml2,read_xml) +importFrom(xml2,xml_attr) +importFrom(xml2,xml_find_all) diff --git a/R/calendar_utils.R b/R/calendar_utils.R index 31d2f185..3cb1d8d5 100644 --- a/R/calendar_utils.R +++ b/R/calendar_utils.R @@ -8,18 +8,22 @@ #' Find the next Wednesday that is not a holiday. When country is given, public holidays are considered, #' using \href{https://date.nager.at/Api}{Nager.Date} API. #' -#' @returns Date +#' @returns Date. The next business Wednesday date. #' #' @examples -#' \dontrun{ -#' next_wednesday = GTFShift::calendar_nextBusinessWednesday(country_code="PT") -#' } +#' # Example of Portuguese holiday (10/06/2026) ignored +#' GTFShift::calendar_nextBusinessWednesday(start_date = "2026-06-09", country_code="PT") +#' +#' # Example of Hong Kong holiday (01/07/2026) ignored +#' GTFShift::calendar_nextBusinessWednesday(start_date = "2026-06-30", country_code="HK") #' #' @import lubridate #' #' @export -calendar_nextBusinessWednesday = function(start_date = Sys.Date(), - country_code = "PT") { +calendar_nextBusinessWednesday = function( + start_date = Sys.Date(), + country_code = "PT" +) { year = lubridate::year(start_date) if (!is.na(country_code)) { holidays = calendar_get_pt_holidays(year, country_code) @@ -28,7 +32,7 @@ calendar_nextBusinessWednesday = function(start_date = Sys.Date(), } # Find the next Wednesday - next_wed = start_date + (4 - lubridate::wday(start_date) + 7) %% 7 + next_wed = lubridate::ymd(start_date) + (4 - lubridate::wday(start_date) + 7) %% 7 # If next Wednesday is a holiday, keep searching while (next_wed %in% holidays) { @@ -48,8 +52,8 @@ calendar_nextBusinessWednesday = function(start_date = Sys.Date(), #' #' Get public holidays for Portugal for a given year. #' @param year Integer. Year to get holidays for. -#' @import httr -#' @import jsonlite +#' @importFrom httr GET status_code +#' @importFrom jsonlite fromJSON #' @noRd calendar_get_pt_holidays = function(year, country_code) { url = paste0("https://date.nager.at/api/v3/PublicHolidays/", year, "/", country_code) diff --git a/R/classify_frequency_los.R b/R/classify_frequency_los.R index 392fef2f..f2b8fc6b 100644 --- a/R/classify_frequency_los.R +++ b/R/classify_frequency_los.R @@ -6,15 +6,30 @@ #' @details #' Classifies bus frequency level of service (LOS) based on the Highway Capacity Manual (HCM) 2000 guidelines #' on "Service Frequency LOS for Urban Scheduled Transit Service" (Exhibit 27-1). +#' +#' Refer to \code{vignette("classify")} for more details on this classification. #' #' @returns data.frame. Input data frame with an additional column \code{frequency_los} indicating the LOS classification. #' #' @examples -#' \dontrun{ -#' gtfs = GTFShift::load_feed("gtfs.zip") -#' frequency_analysis = GTFShift::get_route_frequency_hourly(gtfs) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) +#' +#' # Get route frequency +#' frequency_analysis <- GTFShift::get_route_frequency_hourly( +#' gtfs, +#' date = gtfs$calendar$start_date[1] +#' ) +#' +#' # Compute LOS #' frequency_los = GTFShift::classify_frequency_los(frequency_analysis) -#' } +#' +#' frequency_los |> +#' sf::st_drop_geometry() |> +#' dplyr::select(route_id, frequency_los) #' #' @import dplyr #' diff --git a/R/create_calendar.R b/R/create_calendar.R index b9214abe..4388e0ea 100644 --- a/R/create_calendar.R +++ b/R/create_calendar.R @@ -12,36 +12,42 @@ #' minimum and maximum dates and setting each week day to true if it has any date that matches that date. The results #' might not be 100% accurate, as it captures the whole time span and exceptions in the week days along it are ignored. #' -#' @returns A data.frame for calendar.txt. +#' @returns data.frame. Table for calendar.txt. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' gtfs$calendar <- GTFShift::create_calendar(gtfs) -#' } +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +#' ) +#' +#' head(gtfs$calendar_dates |> dplyr::filter(exception_type == 1)) +#' +#' gtfs_calendar <- GTFShift::create_calendar(gtfs) +#' +#' gtfs_calendar #' #' @import dplyr +#' @importFrom rlang .data #' #' @export create_calendar <- function(gtfs) { - dates = gtfs$calendar_dates %>% - filter(exception_type==1) %>% # Get dates for service inclusion (not removal, which corresponds to exception_type 2) - mutate(weekday = tolower(weekdays(date))) # Get week day from date + dates = gtfs$calendar_dates |> + filter(.data$exception_type==1) |> # Get dates for service inclusion (not removal, which corresponds to exception_type 2) + mutate(weekday = tolower(weekdays(.data$date))) # Get week day from date # Aggregate values in calendar.txt structure - calendar = dates %>% - group_by(service_id) %>% + calendar = dates |> + group_by(.data$service_id) |> summarise( - monday = as.integer(any(weekday == "monday")), - tuesday = as.integer(any(weekday == "tuesday")), - wednesday = as.integer(any(weekday == "wednesday")), - thursday = as.integer(any(weekday == "thursday")), - friday = as.integer(any(weekday == "friday")), - saturday = as.integer(any(weekday == "saturday")), - sunday = as.integer(any(weekday == "sunday")), - start_date = min(date), - end_date = max(date) + monday = as.integer(any(.data$weekday == "monday")), + tuesday = as.integer(any(.data$weekday == "tuesday")), + wednesday = as.integer(any(.data$weekday == "wednesday")), + thursday = as.integer(any(.data$weekday == "thursday")), + friday = as.integer(any(.data$weekday == "friday")), + saturday = as.integer(any(.data$weekday == "saturday")), + sunday = as.integer(any(.data$weekday == "sunday")), + start_date = min(.data$date), + end_date = max(.data$date) ) return(calendar) diff --git a/R/create_shapes_from_sf.R b/R/create_shapes_from_sf.R index e84d9e90..cf36de61 100644 --- a/R/create_shapes_from_sf.R +++ b/R/create_shapes_from_sf.R @@ -13,7 +13,7 @@ #' \code{multiline_to_sorted_linestring}, using a point guide per shape: #' all ordered stops when the selected trip is circular (first and last #' \code{stop_id} are equal), or the first two stops otherwise. -#' Then, it converts the LINESTRING geometries to a data.table representing a GTFS shapes table using +#' Then, it converts the LINESTRING geometries to a data.frame representing a GTFS shapes table using #' \code{gtfstools::convert_sf_to_shapes}. #' #' Coordinates are 4326 (WGS 84) by default, following GTFS specifications. @@ -24,24 +24,36 @@ #' \code{metric_crs}, using \code{GTFShift::project_points_along_geometry()}. #' #' -#' @returns A \code{data.table} representing a GTFS shapes table. Includes +#' @returns data.frame. A GTFS shapes table. Includes #' \code{shape_dist_traveled} if \code{shape_dist_traveled = TRUE}. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' q <- opq("Lisbon") |> -#' add_osm_feature(key = "route", value = c("bus", "tram")) |> -#' add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) -#' -#' shapes_sf <- GTFShift::osm_shapes_to_routes(gtfs, q) -#' -#' gtfs$shapes <- GTFShift::create_shapes_from_sf(shapes_sf, gtfs) -#' } +#' # Load sample GTFS +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' +#' # Load TCB OSM routes sample linestring +#' osm_routes = sf::st_read( +#' system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), +#' quiet = TRUE +#' ) |> dplyr::filter(shape_id %in% gtfs$shapes$shape_id) |> dplyr::sample_n(1) +#' +#' head(osm_routes) +#' +#' # Create shapes.txt for geometries +#' shapes_txt <- GTFShift::create_shapes_from_sf( +#' osm_routes, gtfs, +#' metric_crs = 3763, # Make sure to addapt to the projection that better suits your location +#' shape_dist_traveled = TRUE +#' ) +#' +#' head(shapes_txt) #' #' @import sf -#' @import gtfstools +#' @importFrom gtfstools convert_sf_to_shapes #' @import dplyr +#' @importFrom rlang .data #' #' @seealso \code{gtfstools::convert_sf_to_shapes()} #' @seealso \code{GTFShift::multiline_to_sorted_linestring()} @@ -70,9 +82,9 @@ create_shapes_from_sf <- function( # > circular trip: all stops in sequence # > non-circular trip: first two stops trips_stops_sf <- gtfs$stop_times |> - arrange(trip_id, stop_sequence) |> - left_join(gtfs$trips |> select(trip_id, shape_id), by = "trip_id") |> - left_join(gtfs$stops |> select(stop_id, stop_name, stop_lat, stop_lon), by = "stop_id") |> + arrange(.data$trip_id, .data$stop_sequence) |> + left_join(gtfs$trips |> select("trip_id", "shape_id"), by = "trip_id") |> + left_join(gtfs$stops |> select("stop_id", "stop_name", "stop_lat", "stop_lon"), by = "stop_id") |> st_as_sf(coords = c("stop_lon", "stop_lat"), crs = 4326) trips_points <- split(trips_stops_sf, trips_stops_sf$trip_id) |> @@ -91,11 +103,11 @@ create_shapes_from_sf <- function( bind_rows() shapes_points <- trips_points |> - arrange(shape_id, desc(is_circular), trip_id) |> - group_by(shape_id) |> + arrange(.data$shape_id, desc(.data$is_circular), .data$trip_id) |> + group_by(.data$shape_id) |> slice(1) |> ungroup() |> - select(shape_id, points) + select("shape_id", "points") # Convert MULTILINESTRING to LINESTRING current_geom_col <- attr(sf_shapes, "sf_column") @@ -104,16 +116,16 @@ create_shapes_from_sf <- function( shapes_points, by = "shape_id" ) |> - filter(lengths(points) > 0) |> # Only consider sf_shapes that have a GTFS match + filter(lengths(.data$points) > 0) |> # Only consider sf_shapes that have a GTFS match # sample_n(10) |> # For debug only rowwise() |> mutate(!!current_geom_col := multiline_to_sorted_linestring( multilinestring = .data[[current_geom_col]], - points = points, + points = .data$points, metric_crs = metric_crs )) |> ungroup() |> - select(shape_id) + select("shape_id") #mapview::mapview(sf_shapes_linestrings |> select(-stop_point), zcol="shape_id") #sf_shapes_linestrings_debug = sf_shapes_linestrings|>filter(shape_id=="1-VA-TERM") @@ -138,7 +150,7 @@ create_shapes_from_sf <- function( for (shape_id_i in unique(shapes_gtfstools$shape_id)) { shape_rows <- which(shapes_gtfstools$shape_id == shape_id_i) - shape_geometry <- sf_shapes_linestrings |> filter(shape_id == shape_id_i) |> st_transform(4326) + shape_geometry <- sf_shapes_linestrings |> filter(.data$shape_id == shape_id_i) |> st_transform(4326) if (nrow(shape_geometry) == 0 || length(shape_rows) == 0) { next diff --git a/R/create_shapes_from_stops.R b/R/create_shapes_from_stops.R index 91b52947..2ffbbc56 100644 --- a/R/create_shapes_from_stops.R +++ b/R/create_shapes_from_stops.R @@ -7,15 +7,32 @@ #' The resulting shapes are a simplified version of the original ones, as they do not take into account the actual path followed by the vehicles, but only the stop sequence. #' This can be useful for some applications that do not require high precision in the shapes, and can be used as a fallback when the original feed does not include shapes.txt file. #' -#' @returns The gtfs feed with the shapes table defined and the trips table updated with the matching shape_id. +#' @returns tidygtfs. The GTFS feed with the shapes table defined and the trips table updated with the matching shape_id. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' gtfs$shapes <- GTFShift::create_shapes_from_stops(gtfs) -#' } +#' # Load GTFS without shapes +#' gtfs <- tidytransit::read_gtfs( +#' system.file("extdata/samples", "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs) +#' +#' # Create shapes from GTFS stops data +#' gtfs_with_shapes <- GTFShift::create_shapes_from_stops(gtfs) +#' +#' head(gtfs_with_shapes$shapes) +#' +#' head( +#' gtfs_with_shapes$trips |> +#' dplyr::select(trip_id, shape_id) |> +#' dplyr::distinct(shape_id, .keep_all = TRUE) +#' ) +#' +#' summary(gtfs_with_shapes) #' #' @import dplyr +#' @importFrom tidyr unnest +#' @importFrom rlang .data #' #' @export create_shapes_from_stops <- function(gtfs) { @@ -25,25 +42,25 @@ create_shapes_from_stops <- function(gtfs) { # Get stop_sequence_str for each trip (each will be a different shape) shapes_trips <- gtfs$stop_times |> - select(trip_id, stop_id, stop_sequence) |> - arrange(trip_id, stop_sequence) |> - left_join(gtfs$stops |> select(stop_id, stop_lon, stop_lat), by = "stop_id") |> - group_by(trip_id) |> - arrange(stop_sequence) |> + select("trip_id", "stop_id", "stop_sequence") |> + arrange(.data$trip_id, .data$stop_sequence) |> + left_join(gtfs$stops |> select("stop_id", "stop_lon", "stop_lat"), by = "stop_id") |> + group_by(.data$trip_id) |> + arrange(.data$stop_sequence) |> # Create string with stop_id sequence for each trip, to be used as a key to group trips with the same stop sequence - mutate(stop_sequence_str = paste(stop_id, collapse = "-")) |> + mutate(stop_sequence_str = paste(.data$stop_id, collapse = "-")) |> ungroup() # Get unique stop_sequence_str shapes_trips_geom <- shapes_trips |> - select(stop_sequence_str, stop_id, stop_sequence, stop_lon, stop_lat) |> + select("stop_sequence_str", "stop_id", "stop_sequence", "stop_lon", "stop_lat") |> distinct() # Gnerate shape_id shapes <- shapes_trips |> - group_by(stop_sequence_str) |> + group_by(.data$stop_sequence_str) |> reframe( - trip_id = list(trip_id) + trip_id = list(.data$trip_id) ) |> mutate( shape_id = paste0("shape-", 1:n()) @@ -52,18 +69,18 @@ create_shapes_from_stops <- function(gtfs) { # Asssociate trips to shape_id gtfs$trips <- gtfs$trips |> - select(-shape_id) |> - left_join(shapes |> tidyr::unnest(cols = "trip_id"), join_by(trip_id)) + select(-"shape_id") |> + left_join(shapes |> tidyr::unnest(cols = "trip_id") |> select("trip_id", "shape_id") |> distinct(), by = "trip_id") # Gather shape_id and shape geometry (from shapes_trips_geom) gtfs$shapes <- shapes |> - select(-trip_id) |> + select(-"trip_id") |> left_join(shapes_trips_geom, by = "stop_sequence_str") |> - select(-stop_sequence_str, -stop_id) |> + select(-"stop_sequence_str", -"stop_id") |> rename( - shape_pt_lat = stop_lat, - shape_pt_lon = stop_lon, - shape_pt_sequence = stop_sequence + shape_pt_lat = .data$stop_lat, + shape_pt_lon = .data$stop_lon, + shape_pt_sequence = .data$stop_sequence ) return(gtfs) diff --git a/R/filter_by_agency.R b/R/filter_by_agency.R index 08c3e7f4..d53b7dfe 100644 --- a/R/filter_by_agency.R +++ b/R/filter_by_agency.R @@ -7,46 +7,60 @@ #' @details #' Allows to filter a GTFS feed for the agency, using the id, name or both. Returns empty feed it none provided. #' -#' @returns A tidygtfs object with the filtered feed. +#' @returns tidygtfs. The filtered GTFS feed. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' gtfs_filtered_by_id <- GTFShift::filter_by_agency(gtfs, agency_id=2) -#' gtfs_filtered_by_name <- GTFShift::filter_by_agency(gtfs, agency_name="City bus company") -#' } +#' # Load sample feed with multiple agencies +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_merged_sample.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs) +#' +#' +#' # Filter by id +#' gtfs_id_8 = gtfs |> GTFShift::filter_by_agency(id = "8") +#' +#' summary(gtfs_id_8) +#' +#' +#' # Filter by name +#' gtfs_ttsl <- gtfs |> GTFShift::filter_by_agency(name = "TTSL - Transtejo Soflusa") +#' +#' summary(gtfs_ttsl) #' #' @import tidytransit #' @import dplyr +#' @importFrom rlang .data #' #' @export filter_by_agency <- function(gtfs, id=NA, name=NA) { # Get agencies that match query - agencies = gtfs$agency %>% + agencies = gtfs$agency |> filter( - if (!is.na(id) & !is.na(name)) agency_id==id && agency_name==name - else if (!is.na(id)) agency_id==id - else if (!is.na(name)) agency_name==name + if (!is.na(id) & !is.na(name)) .data$agency_id==id && .data$agency_name==name + else if (!is.na(id)) .data$agency_id==id + else if (!is.na(name)) .data$agency_name==name else FALSE ) # Get routes that match query - routes = gtfs$routes %>% + routes = gtfs$routes |> filter( - agency_id %in% agencies$agency_id + .data$agency_id %in% agencies$agency_id ) # Get trips that match those routes - trips = gtfs$trips %>% - filter(route_id %in% routes$route_id) + trips = gtfs$trips |> + filter(.data$route_id %in% routes$route_id) # Filter feed by trip id gtfs_filtered = tidytransit::filter_feed_by_trips(gtfs, trip_ids = trips$trip_id) # Filter agency table routes_agencies <- unique(gtfs_filtered$routes$agency_id) - gtfs_filtered$agency = gtfs_filtered$agency |> filter(agency_id %in% routes_agencies) + gtfs_filtered$agency = gtfs_filtered$agency |> filter(.data$agency_id %in% routes_agencies) return(gtfs_filtered) } diff --git a/R/filter_by_mode.R b/R/filter_by_mode.R index fa36abe5..1dbbd69a 100644 --- a/R/filter_by_mode.R +++ b/R/filter_by_mode.R @@ -8,29 +8,42 @@ #' Refer to \code{routes.txt} \code{route_type} parameter on #' \href{https://gtfs.org/documentation/schedule/reference/#routestxt}{GTFS documentation} for more details. #' -#' @returns A tidygtfs object with the filtered feed. +#' @returns tidygtfs. The filtered GTFS feed. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' gtfs_filtered <- GTFShift::filter_by_modes(gtfs, list(0,1)) -#' } +#' # Load sample feed with multiple modes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_merged_sample.zip", package = "GTFShift") +#' ) +#' +#' gtfs$routes |> dplyr::select(route_id, route_type) +#' +#' summary(gtfs) +#' +#' +#' # Filter by bus mode (ferry agency should be excluded) +#' gtfs_bus <- gtfs |> GTFShift::filter_by_modes(modes = c(3)) +#' +#' gtfs_bus$routes |> dplyr::select(route_id, route_type) +#' +#' summary(gtfs_bus) #' #' @import tidytransit #' @import dplyr +#' @importFrom rlang .data #' #' @export filter_by_modes <- function(gtfs, modes=list()) { # Get routes that match query - routes = gtfs$routes %>% + routes = gtfs$routes |> filter( - route_type %in% modes + .data$route_type %in% modes ) # Get trips that match those routes - trips = gtfs$trips %>% - filter(route_id %in% routes$route_id) + trips = gtfs$trips |> + filter(.data$route_id %in% routes$route_id) # Filter feed by trip id gtfs_filtered = tidytransit::filter_feed_by_trips(gtfs, trip_ids = trips$trip_id) diff --git a/R/filter_by_route_name.R b/R/filter_by_route_name.R index 64800a51..7b99e198 100644 --- a/R/filter_by_route_name.R +++ b/R/filter_by_route_name.R @@ -10,17 +10,26 @@ #' letters, words or combinations of both. #' This method allows to filter the feed for the route short or long name, with a partial or exact match. #' -#' @returns A tidygtfs object with the filtered feed. +#' @returns tidygtfs. The filtered GTFS feed. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' gtfs_filtered <- GTFShift::filter_by_route_name(gtfs, list("Blue line", "Red line")) -#' } +#' # Load GTFS +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs) +#' +#' +#' # Filter by route +#' gtfs_route <- GTFShift::filter_by_route_name(gtfs, c("4")) +#' +#' summary(gtfs_route) #' #' @import tidytransit #' @import dplyr -#' @import stringr +#' @importFrom stringr str_detect regex +#' @importFrom rlang .data #' #' @export filter_by_route_name <- function(gtfs, values, short_name=TRUE, exact_match=TRUE) { @@ -28,17 +37,17 @@ filter_by_route_name <- function(gtfs, values, short_name=TRUE, exact_match=TRUE # Get routes that match query pattern <- paste(unlist(values), collapse = "|") - routes = gtfs$routes %>% + routes = gtfs$routes |> filter( - if (short_name & exact_match) route_short_name %in% values - else if (short_name) str_detect(route_short_name, regex(pattern, ignore_case = TRUE)) - else if (!short_name & exact_match) route_long_name %in% values - else str_detect(route_long_name, regex(pattern, ignore_case = TRUE)) + if (short_name & exact_match) .data$route_short_name %in% values + else if (short_name) str_detect(.data$route_short_name, regex(pattern, ignore_case = TRUE)) + else if (!short_name & exact_match) .data$route_long_name %in% values + else str_detect(.data$route_long_name, regex(pattern, ignore_case = TRUE)) ) # Get trips that match those routes - trips = gtfs$trips %>% - filter(route_id %in% routes$route_id) + trips = gtfs$trips |> + filter(.data$route_id %in% routes$route_id) # Filter feed by trip id gtfs_filtered = tidytransit::filter_feed_by_trips(gtfs, trip_ids = trips$trip_id) diff --git a/R/get_network_extension.R b/R/get_network_extension.R index fb6528e6..dbfeb4e5 100644 --- a/R/get_network_extension.R +++ b/R/get_network_extension.R @@ -3,7 +3,7 @@ #' Get total extension of GTFS feed routes #' #' @param gtfs tidygtfs. GTFS feed. -#' @param route_identifier. String. (Default \code{"route_id"}). routes.txt attribute that identifies routes. Accepted values: route_id, route_short_name, route_long_name. +#' @param route_identifier String. (Default \code{"route_id"}). routes.txt attribute that identifies routes. Accepted values: route_id, route_short_name, route_long_name. #' @param direction_wise Boolean (Default \code{TRUE}). If TRUE, extension considers sum of both directions. Otherwise, only one direction is considered. #' @param unified Boolean (Default \code{FALSE}). If TRUE, overlapping route segments are only counted once in the total extension. #' @param date Date (Default \code{GTFShift::calendar_nextBusinessWednesday()}). Reference date to consider when analyzing the GTFS file. @@ -15,18 +15,27 @@ #' (using \code{GTFShift::get_route_frequency_hourly()}). #' For a detailed example, see the \code{vignette("analyse")}. #' -#' @returns The routes extension, in meters. +#' @returns Numeric. The routes extension, in meters. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' route_extension <- GTFShift::get_network_extension(gtfs) -#' } +#' # Load GTFS +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", +#' package = "GTFShift" +#' )) #' -#' @seealso [GTFShift::get_route_frequency_hourly()] +#' # Get route extension +#' GTFShift::get_network_extension( +#' gtfs, +#' metric_crs = 3763, # Make sure to addapt to the projection that better suits your location +#' date = gtfs$calendar$start_date[1] +#' ) +#' +#' @seealso \code{GTFShift::get_route_frequency_hourly()} #' #' @import dplyr #' @import sf +#' @importFrom rlang .data #' #' @export get_network_extension <- function( @@ -60,28 +69,28 @@ get_network_extension <- function( # Get unique shapes shapes_unique <- network |> st_drop_geometry() |> - select(shape_id) |> + select("shape_id") |> distinct() |> left_join(network, by = "shape_id", multiple = "first") # Compute daily frequencies per route shape network_redux <- network |> st_drop_geometry() |> - group_by(.data[[route_identifier]], direction_id, shape_id) |> - summarise(frequency_day = sum(frequency)) |> + group_by(.data[[route_identifier]], .data$direction_id, .data$shape_id) |> + summarise(frequency_day = sum(.data$frequency)) |> ungroup() # Get shape with max frequencies per route 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)) |> + group_by(.data[[route_identifier]], .data$shape_id, !!!if (direction_wise) rlang::syms("direction_id")) |> + summarise(frequency_max = max(.data$frequency_day)) |> # Get shape with max frequency per route (and direction, if direction_wise=TRUE) group_by( .data[[route_identifier]], !!!if (direction_wise) rlang::syms("direction_id") ) |> - slice_max(order_by = frequency_max, n = 1, with_ties = FALSE) |> + slice_max(order_by = .data$frequency_max, n = 1, with_ties = FALSE) |> ungroup() # Join with the original network to get the shapes and compute its distance @@ -95,12 +104,14 @@ get_network_extension <- function( # Compute unified network extension if (unified) { + if (!requireNamespace("stplanr", quietly = TRUE)) { + stop("Package 'stplanr' is required when unified=TRUE. Install it with: install.packages('stplanr')") + } network_union <- network_redux_shapes |> st_union() |> stplanr::line_cast() |> - st_as_sf() |> - mutate(length = st_length(geom_col)) - return(sum(network_union$length)) + st_as_sf() + return(sum(st_length(st_geometry(network_union)))) } return(sum(network_redux_shapes$length)) diff --git a/R/get_prioritisation_stats.R b/R/get_prioritisation_stats.R new file mode 100644 index 00000000..6bd33e05 --- /dev/null +++ b/R/get_prioritisation_stats.R @@ -0,0 +1,106 @@ +#' Get prioritisation stats +#' +#' Get statistics about lane prioritisation +#' +#' @param lane_prioritisation sf data.frame. Lane prioritisation. +#' @param weight Character. Weight to use for weighted mean. Accepted values: "length", "frequency". +#' @param metric_crs Integer or character (Default 3857). Projected CRS used to compute lengths in meters. +#' +#' @returns List. Statistics about lane prioritisation, with the following attributes: +#' \describe{ +#' \item{extension}{Total length of the prioritised network, in meters.} +#' \item{extension_bus_lane}{Total length of the bus lane segments, in meters.} +#' \item{speed_avg}{Average speed of the prioritised network, in km/h.} +#' \item{speed_min}{Minimum speed of the prioritised network, in km/h.} +#' \item{speed_max}{Maximum speed of the prioritised network, in km/h.} +#' \item{n_lanes_circulation_avg}{Average number of lanes in the prioritised network.} +#' \item{n_lanes_circulation_min}{Minimum number of lanes in the prioritised network.} +#' \item{n_lanes_circulation_max}{Maximum number of lanes in the prioritised network.} +#' } +#' +#' @examplesIf nzchar(Sys.which("osmium")) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("4")) +#' +#' # Build query and prepare osm extract (possible to use API as alternative) +#' q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> +#' osmdata::add_osm_feature(key = "route", value = "bus") |> +#' osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +#' osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") +#' +#' # Prioritise lanes +#' lane_prioritisation <- GTFShift::prioritise_lanes( +#' gtfs, q, +#' osm_file = osm_file, +#' date = gtfs$calendar$start_date[1] +#' ) +#' +#' # Get statistics for prioritisation +#' stats <- GTFShift::get_prioritisation_stats(lane_prioritisation, metric_crs = 3763) +#' +#' data.frame(metric = names(stats), value = unlist(stats, use.names = FALSE)) +#' +#' @import dplyr +#' @import sf +#' @importFrom stats weighted.mean +#' @importFrom rlang .data +#' +#' @export +get_prioritisation_stats <- function( + lane_prioritisation, + weight = c("length", "frequency"), + metric_crs = 3857 +) { + metric_crs_is_default <- missing(metric_crs) + weight <- match.arg(weight) + metric_crs <- suppressWarnings(sf::st_crs(metric_crs)) + if (is.na(metric_crs)) { + stop("metric_crs should be a valid CRS value (e.g., 3857 or 'EPSG:3857')") + } + if (metric_crs_is_default) { + warning( + "Using default metric_crs (EPSG:3857). Consider setting metric_crs to a projected CRS better suited to your local context for more accurate distance calculations.", + call. = FALSE + ) + } + + prioritisation_internal <- lane_prioritisation |> + st_as_sf() |> + st_transform(crs = metric_crs) + + geom_col <- st_geometry(prioritisation_internal) + prioritisation_internal <- prioritisation_internal |> + mutate( + length = as.numeric(st_length(geom_col)) + ) |> + st_drop_geometry() + stats <- list() + + # Compute bus lane extension + stats$extension <- sum(prioritisation_internal$length, na.rm = TRUE) + stats$extension_bus_lane <- sum( + prioritisation_internal |> filter(.data$is_bus_lane) |> pull(.data$length), + na.rm = TRUE + ) + + # Compute average speed, weighted by chosen weight + if ("speed_avg" %in% names(prioritisation_internal)) { + stats$speed_avg <- weighted.mean(prioritisation_internal$speed_avg, prioritisation_internal[[weight]], na.rm = TRUE) + stats$speed_min <- min(prioritisation_internal$speed_avg, na.rm = TRUE) + stats$speed_max <- max(prioritisation_internal$speed_avg, na.rm = TRUE) + } + + # Compute number of lanes, weighted by chosen weight + stats$n_lanes_circulation_avg <- weighted.mean(prioritisation_internal$n_lanes_circulation, prioritisation_internal[[weight]], na.rm = TRUE) + stats$n_lanes_circulation_min <- min(prioritisation_internal$n_lanes_circulation, na.rm = TRUE) + stats$n_lanes_circulation_max <- max(prioritisation_internal$n_lanes_circulation, na.rm = TRUE) + + stats$n_lanes_parking_avg <- weighted.mean(prioritisation_internal$n_lanes_parking, prioritisation_internal[[weight]], na.rm = TRUE) + stats$n_lanes_parking_min <- min(prioritisation_internal$n_lanes_parking, na.rm = TRUE) + stats$n_lanes_parking_max <- max(prioritisation_internal$n_lanes_parking, na.rm = TRUE) + + return(stats) +} diff --git a/R/get_prioritization_stats.R b/R/get_prioritization_stats.R deleted file mode 100644 index 159c7e99..00000000 --- a/R/get_prioritization_stats.R +++ /dev/null @@ -1,85 +0,0 @@ -#' 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". -#' @param metric_crs Integer or character (Default 3857). Projected CRS used to compute lengths in meters. -#' -#' @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_circulation_avg}{Average number of lanes in the prioritized network.} -#' \item{n_lanes_circulation_min}{Minimum number of lanes in the prioritized network.} -#' \item{n_lanes_circulation_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"), - metric_crs = 3857 -) { - metric_crs_is_default <- missing(metric_crs) - weight <- match.arg(weight) - metric_crs <- suppressWarnings(sf::st_crs(metric_crs)) - if (is.na(metric_crs)) { - stop("metric_crs should be a valid CRS value (e.g., 3857 or 'EPSG:3857')") - } - if (metric_crs_is_default) { - warning( - "Using default metric_crs (EPSG:3857). Consider setting metric_crs to a projected CRS better suited to your local context for more accurate distance calculations.", - call. = FALSE - ) - } - - prioritization_internal <- lane_prioritization |> - st_as_sf() |> - st_transform(crs = metric_crs) - - 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_circulation_avg <- weighted.mean(prioritization_internal$n_lanes_circulation, prioritization_internal[[weight]], na.rm = TRUE) - stats$n_lanes_circulation_min <- min(prioritization_internal$n_lanes_circulation, na.rm = TRUE) - stats$n_lanes_circulation_max <- max(prioritization_internal$n_lanes_circulation, na.rm = TRUE) - - stats$n_lanes_parking_avg <- weighted.mean(prioritization_internal$n_lanes_parking, prioritization_internal[[weight]], na.rm = TRUE) - stats$n_lanes_parking_min <- min(prioritization_internal$n_lanes_parking, na.rm = TRUE) - stats$n_lanes_parking_max <- max(prioritization_internal$n_lanes_parking, na.rm = TRUE) - - return(stats) -} diff --git a/R/get_route_frequency_hourly.R b/R/get_route_frequency_hourly.R index b3b0b4dd..15f4a1d5 100644 --- a/R/get_route_frequency_hourly.R +++ b/R/get_route_frequency_hourly.R @@ -21,9 +21,9 @@ #' #' For a detailed example, see the \code{vignette("analyse")}. #' -#' Adapted from \url{https://github.com/Bondify/GTFS_in_R/}. +#' Adapted from \href{https://web.archive.org/web/20201223060409/https://github.com/Bondify/GTFS_in_R/}{github.com/Bondify/GTFS_in_R}. #' -#' @returns An \code{sf} \code{data.frame} object with the following columns (the first three are only present if \code{overline=FALSE}): +#' @returns sf data.frame. Hourly route frequencies, with the following columns (the first three are only present if \code{overline=FALSE}): #' \describe{ #' \item{route_id}{The \code{route_id} attribute from \code{routes.txt} file.} #' \item{route_short_name}{The \code{route_short_name} attribute from \code{routes.txt} file.} @@ -35,10 +35,19 @@ #' } #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' frequency_analysis <- GTFShift::get_route_frequency_hourly(gtfs) -#' } +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) +#' +#' # Get frequency +#' frequency_analysis <- GTFShift::get_route_frequency_hourly( +#' gtfs, +#' date = gtfs$calendar$start_date[1] +#' ) +#' +#' head(frequency_analysis |> sf::st_drop_geometry()) #' #' @seealso \code{GTFShift::calendar_nextBusinessWednesday()} #' @seealso \code{GTFShift::osm_shapes_to_routes()} @@ -47,9 +56,9 @@ #' @import tidytransit #' @import dplyr #' @import sf -#' @import tidyverse #' @import lubridate -#' @import stplanr +#' @importFrom tidyselect any_of +#' @importFrom rlang .data #' #' @export get_route_frequency_hourly <- function( @@ -62,7 +71,9 @@ get_route_frequency_hourly <- function( ## Consider transit data for one day only message(sprintf("> Filtering by reference date %s...", date)) - gtfs_date <- tidytransit::filter_feed_by_date(gtfs, extract_date = date) + suppressWarnings({ # Ignore missing transfers warnings + gtfs_date <- tidytransit::filter_feed_by_date(gtfs, extract_date = date) + }) # PROCESS GTFS, generating table calculating the frequencies per route trips <- gtfs_date$trip @@ -77,8 +88,8 @@ get_route_frequency_hourly <- function( stop_times <- gtfs_date$stop_times stop_times <- stop_times |> - left_join(trips) |> - left_join(routes) |> + left_join(trips, by="trip_id") |> + left_join(routes, by="route_id") |> select(any_of(c( "route_id", "route_short_name", @@ -93,11 +104,11 @@ get_route_frequency_hourly <- function( ))) stop_times <- stop_times |> - arrange(stop_sequence) |> - group_by(trip_id) |> + arrange(.data$stop_sequence) |> + group_by(.data$trip_id) |> slice(1) |> # Only departures from origin (first stop) ungroup() |> - mutate(hour = lubridate::hour(departure_time)) + mutate(hour = lubridate::hour(.data$departure_time)) freq_data <- stop_times |> group_by(across(any_of(c("route_id", "shape_id", "route_short_name", "direction_id", "hour")))) |> @@ -106,17 +117,20 @@ get_route_frequency_hourly <- function( routes_freq <- freq_data |> - inner_join(shapes) |> + inner_join(shapes, by="shape_id") |> st_as_sf() # Overline? if (overline) { + if (!requireNamespace("stplanr", quietly = TRUE)) { + stop("Package 'stplanr' is required when overline=TRUE. Install it with: install.packages('stplanr')") + } routes_freq_all <- data.frame() for (h in unique(routes_freq$hour)) { # hours of the day routes_freq_h <- routes_freq |> - filter(hour == h) |> + filter(.data$hour == h) |> stplanr::overline2(attrib = "frequency") |> - arrange(frequency) |> + arrange(.data$frequency) |> mutate(hour = h) routes_freq_all <- rbind(routes_freq_all, routes_freq_h) diff --git a/R/get_stop_frequency_hourly.R b/R/get_stop_frequency_hourly.R index 7c7c1d05..0bbec809 100644 --- a/R/get_stop_frequency_hourly.R +++ b/R/get_stop_frequency_hourly.R @@ -9,7 +9,7 @@ #' This method analyses the GTFS feed for a representative day, generating for each stop the number of services aggregated per hour. #' For a detailed example, see the \code{vignette("analyse")}. #' -#' @returns An \code{sf} \code{data.frame} object with the following columns: +#' @returns sf data.frame. Hourly stop frequencies, with the following columns: #' \describe{ #' \item{stop_id}{The \code{stop_id} attribute from \code{stops.txt} file.} #' \item{hour}{The hour for which the frequency applies (24 hour format).} @@ -18,18 +18,27 @@ #' } #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") -#' frequency_analysis <- GTFShift::get_stop_frequency_hourly(gtfs) -#' } +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) +#' +#' # Get frequency +#' frequency_analysis <- GTFShift::get_stop_frequency_hourly( +#' gtfs, +#' date = gtfs$calendar$start_date[1] +#' ) +#' +#' head(frequency_analysis) #' #' @seealso \code{GTFShift::calendar_nextBusinessWednesday()} #' #' @import sf -#' @import tidyverse #' @import lubridate #' @import tidytransit #' @import dplyr +#' @importFrom rlang .data #' #' @export get_stop_frequency_hourly <- function(gtfs, date = GTFShift::calendar_nextBusinessWednesday()) { @@ -37,9 +46,11 @@ get_stop_frequency_hourly <- function(gtfs, date = GTFShift::calendar_nextBusine ## Consider transit data for one day only message(sprintf("> Filtering by reference date %s...", date)) - gtfs_date <- tidytransit::filter_feed_by_date( - gtfs, extract_date = date - ) + suppressWarnings({ # Ignore missing transfers warnings + gtfs_date <- tidytransit::filter_feed_by_date( + gtfs, extract_date = date + ) + }) message(sprintf("> Found %d routes operating %d trips on %d stops...", length(gtfs_date$trips$trip_id), @@ -66,35 +77,35 @@ get_stop_frequency_hourly <- function(gtfs, date = GTFShift::calendar_nextBusine shape_lengths <- pattern_gtfs$shapes |> as.data.frame() |> - select(shape_id, length, -geometry) + select("shape_id", "length", -"geometry") ## Get statistics: for each service pattern, get nr of trips, routes, total and avg distance and number of stops covered service_pattern_summary <- pattern_gtfs$trips |> # Join trips left_join(pattern_gtfs$.$servicepatterns, by="service_id") |> # with service pattern left_join(shape_lengths, by="shape_id") |> # with shape length left_join(pattern_gtfs$stop_times, by="trip_id") |> # with planned route (stops and times) - group_by(servicepattern_id) |> # group by service pattern + group_by(.data$servicepattern_id) |> # group by service pattern summarise( trips = n(), - routes = n_distinct(route_id), - total_distance_per_day_km = sum(as.numeric(length), na.rm=TRUE)/1e3, # divide by 1e3 to convert meters to kms - route_avg_distance_km = (sum(as.numeric(length), na.rm=TRUE)/1e3)/(trips*routes), - stops=(n_distinct(stop_id)/2) # divided by two because usually there is one stop per direction + routes = n_distinct(.data$route_id), + total_distance_per_day_km = sum(as.numeric(.data$length), na.rm=TRUE)/1e3, # divide by 1e3 to convert meters to kms + route_avg_distance_km = (sum(as.numeric(.data$length), na.rm=TRUE)/1e3)/(.data$trips*.data$routes), + stops=(n_distinct(.data$stop_id)/2) # divided by two because usually there is one stop per direction ) ## Add the number of days that each service is in operation (by join with $.$dates_servicepatterns) service_pattern_summary <- pattern_gtfs$.$dates_servicepatterns |> - group_by(servicepattern_id) |> + group_by(.data$servicepattern_id) |> summarise(days_in_service = n()) |> left_join(service_pattern_summary, by = "servicepattern_id") ## Get service patterns that run on the date selected service_pattern_ids = pattern_gtfs$.$dates_servicepatterns |> - filter(date==date) + filter(.data$date==date) service_ids = pattern_gtfs$.$servicepattern |> - filter(servicepattern_id %in% service_pattern_ids$servicepattern_id) |> - pull(service_id) + filter(.data$servicepattern_id %in% service_pattern_ids$servicepattern_id) |> + pull(.data$service_id) #### Filter by date @@ -102,7 +113,7 @@ get_stop_frequency_hourly <- function(gtfs, date = GTFShift::calendar_nextBusine frame = data.frame() - stop_times = gtfs_date$stop_times |> mutate(hour = lubridate::hour(departure_time)) + stop_times = gtfs_date$stop_times |> mutate(hour = lubridate::hour(.data$departure_time)) min_hour = min(stop_times$hour, na.rm=TRUE) max_hour = max(stop_times$hour, na.rm=TRUE) @@ -118,8 +129,8 @@ get_stop_frequency_hourly <- function(gtfs, date = GTFShift::calendar_nextBusine ) stop_frequency <- stop_frequency |> - group_by(stop_id) |> - summarise(frequency = sum(n_departures)) |> + group_by(.data$stop_id) |> + summarise(frequency = sum(.data$n_departures)) |> mutate(hour = i) frame <- rbind(frame, stop_frequency) @@ -127,13 +138,13 @@ get_stop_frequency_hourly <- function(gtfs, date = GTFShift::calendar_nextBusine frequency <- frame |> ungroup() |> - group_by(stop_id, hour) |> - summarise(frequency = sum(frequency)) |> + group_by(.data$stop_id, .data$hour) |> + summarise(frequency = sum(.data$frequency)) |> ungroup() table <- frequency |> left_join(gtfs_date$stops |> - select(stop_id, stop_lon, stop_lat), by = "stop_id") |> + select("stop_id", "stop_lon", "stop_lat"), by = "stop_id") |> st_as_sf(crs = 4326, coords = c("stop_lon", "stop_lat")) message("Finished GTFS analysis!") diff --git a/R/get_way_frequency_hourly.R b/R/get_way_frequency_hourly.R index 74b0059f..963ca3fa 100644 --- a/R/get_way_frequency_hourly.R +++ b/R/get_way_frequency_hourly.R @@ -14,7 +14,7 @@ #' #' For a detailed example, see the \code{vignette("analyse")}. #' -#' @returns An \code{sf} \code{data.frame} object with the following columns: +#' @returns sf data.frame. Hourly way frequencies, with the following columns: #' \describe{ #' \item{way_osm_id}{The \code{osm_id} attribute from OSM way.} #' \item{hour}{The hour for which the frequency applies (24 hour format).} @@ -25,18 +25,27 @@ #' \item{(if \code{keep_osm_attributes = TRUE})}{All OSM way attributes.} #' } #' -#' @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") -#' -#' # To use OSM API: -#' frequency_analysis <- GTFShift::get_way_frequency_hourly(gtfs, q) -#' -#' # To use a local OSM file: -#' osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -#' frequency_analysis <- GTFShift::get_way_frequency_hourly(gtfs, q, osm_file = osm_file) -#' } +#' @examplesIf nzchar(Sys.which("osmium")) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) +#' +#' # Build query and prepare osm extract (possible to use API as alternative) +#' q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> +#' osmdata::add_osm_feature(key = "route", value = "bus") |> +#' osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +#' osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") +#' +#' # Get frequency +#' frequency_analysis <- GTFShift::get_way_frequency_hourly( +#' gtfs, q, +#' date = gtfs$calendar$start_date[1], +#' osm_file = osm_file +#' ) +#' +#' head(frequency_analysis |> sf::st_drop_geometry()) #' #' @seealso \code{GTFShift::calendar_nextBusinessWednesday()} #' @seealso \code{GTFShift::osm_shapes_to_routes()} @@ -44,8 +53,9 @@ #' @import tidytransit #' @import dplyr #' @import sf -#' @import tidyverse #' @import lubridate +#' @importFrom tidyselect any_of +#' @importFrom rlang .data #' #' @export get_way_frequency_hourly <- function( @@ -59,7 +69,9 @@ get_way_frequency_hourly <- function( ## Consider transit data for one day only message(sprintf("> Filtering by reference date %s...", date)) - gtfs_date <- tidytransit::filter_feed_by_date(gtfs, extract_date = date) + suppressWarnings({ # Ignore missing transfers warnings + gtfs_date <- tidytransit::filter_feed_by_date(gtfs, extract_date = date) + }) # PROCESS GTFS, generating table calculating the frequencies per route trips <- gtfs_date$trips @@ -70,8 +82,8 @@ get_way_frequency_hourly <- function( stop_times <- gtfs_date$stop_times stop_times <- stop_times |> - left_join(trips) |> - left_join(routes) |> + left_join(trips, by = "trip_id") |> + left_join(routes, by = "route_id") |> select(any_of(c( "route_id", "route_short_name", @@ -86,11 +98,11 @@ get_way_frequency_hourly <- function( ))) stop_times <- stop_times |> - arrange(stop_sequence) |> - group_by(trip_id) |> + arrange(.data$stop_sequence) |> + group_by(.data$trip_id) |> slice(1) |> # Only departures from origin (first stop) ungroup() |> - mutate(hour = lubridate::hour(departure_time)) + mutate(hour = lubridate::hour(.data$departure_time)) freq_data <- stop_times |> group_by(across(any_of(c("route_id", "route_short_name", "direction_id", "hour")))) |> @@ -99,27 +111,31 @@ get_way_frequency_hourly <- function( routes_freq <- freq_data |> - left_join(trips |> - select(any_of(c("route_id", "direction_id", "shape_id"))) |> - distinct(), relationship = "many-to-many") |> + left_join( + trips |> + select(any_of(c("route_id", "direction_id", "shape_id"))) |> + distinct(), + by = c("route_id", "direction_id"), + relationship = "many-to-many" + ) |> as.data.frame() # Join with ways ways_unique_geometry <- ways |> - distinct(way_osm_id, .keep_all = TRUE) + distinct(.data$way_osm_id, .keep_all = TRUE) if (!keep_osm_attributes) { ways_unique_geometry <- ways_unique_geometry |> - select(way_osm_id, geometry) + select("way_osm_id", "geometry") } ways_freq <- routes_freq |> - inner_join(ways |> sf::st_drop_geometry() |> select(shape_id, way_osm_id), by = "shape_id", relationship = "many-to-many") |> - group_by(way_osm_id, hour) |> + inner_join(ways |> sf::st_drop_geometry() |> select("shape_id", "way_osm_id"), by = "shape_id", relationship = "many-to-many") |> + group_by(.data$way_osm_id, .data$hour) |> summarize( - frequency = sum(frequency), - routes = list(unique(route_id)), - shapes = list(unique(shape_id)) + frequency = sum(.data$frequency), + routes = list(unique(.data$route_id)), + shapes = list(unique(.data$shape_id)) ) |> ungroup() |> inner_join(ways_unique_geometry, by = "way_osm_id") |> diff --git a/R/load_feed.R b/R/load_feed.R index 838e6ac4..3c02006f 100644 --- a/R/load_feed.R +++ b/R/load_feed.R @@ -19,16 +19,39 @@ #' the parameters \code{d_limit=transfer_distance}, \code{min_transfer_time=transfer_time} and \code{network_times=transfer_street_routing}. #' The other parameters are applied the library default values. #' -#' @returns A tidygtfs object. +#' @returns tidygtfs. The loaded GTFS feed. #' #' @seealso \code{GTFShift::create_shapes_from_stops()} #' @seealso \code{tidytransit::read_gtfs()} #' @seealso \code{gtfsrouter::gtfs_transfer_table()} #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("https://operator.com/gtfs.zip") -#' } +#' # Simple call +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs) +#' +#' +#' # Simple call with missing shapes (triggering shapes creation because missing on GTFS file) +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs) +#' +#' +#' # With some parameters to build transfers and store to given location +#' store_path <- withr::local_tempfile(fileext = ".zip") +#' +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift"), create_transfers = TRUE, store_path +#' ) +#' +#' head(gtfs$transfers) +#' +#' file.exists(store_path) #' #' @import tidytransit #' @@ -36,7 +59,7 @@ load_feed <- function(path, store_path = NA, create_transfers = FALSE, 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") + temp_zip <- withr::local_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 @@ -68,9 +91,11 @@ load_feed <- function(path, store_path = NA, create_transfers = FALSE, transfer_ # Generate transfers.txt if (create_transfers) { + if (!requireNamespace("gtfsrouter", quietly = TRUE)) { + stop("Package 'gtfsrouter' is required to generate transfers. Install it with: install.packages('gtfsrouter')") + } # Store in temporary file because gtfsrouter can not convert from tidytransit format - temp_dir <- tempfile() - dir.create(temp_dir) + temp_dir <- withr::local_tempdir() gtfs_temp <- file.path(temp_dir, "gtfs.zip") tidytransit::write_gtfs(gtfs, gtfs_temp) diff --git a/R/multiline_to_sorted_linestring.R b/R/multiline_to_sorted_linestring.R index 879d64c8..bc8999c2 100644 --- a/R/multiline_to_sorted_linestring.R +++ b/R/multiline_to_sorted_linestring.R @@ -22,7 +22,7 @@ #' \deqn{L^{(1)} = \operatorname*{argmin}_{L \in \mathcal{L}} d(\mathrm{start\_point}, L).} #' where \eqn{d(\cdot)} is the Euclidean distance. If no points are provided, \eqn{L^{(1)} = L_1} (assuming the input MULTILINESTRING is ordered). #' -#' Additionaly, the orientation of \eqn{L^{(1)}} is determined by comparing the distances +#' Additionally, the orientation of \eqn{L^{(1)}} is determined by comparing the distances #' from its edges to the remaining segments in \eqn{\mathcal{L} \setminus \{L^{(1)}\}}. #' The edge that is closest to any remaining segment is designated as the end of \eqn{L^{(1)}}. #' @@ -56,11 +56,27 @@ #' The ordered segments are concatenated into a single \code{LINESTRING} and #' transformed back to the original CRS of \code{multilinestring}. #' -#' @returns A \code{sfc} object with LINESTRING geometry. +#' @returns sfc. LINESTRING geometry object. +#' +#' @examples +#' # Get OSM route geometries (MULTILINESTRING) +#' osm_routes <- sf::st_read( +#' system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), +#' quiet = TRUE +#' ) |> dplyr::sample_n(1) +#' +#' head(osm_routes) +#' +#' # Convert geometry to LINESTRING +#' osm_routes <- osm_routes |> dplyr::mutate( +#' geom = GTFShift::multiline_to_sorted_linestring(geom, metric_crs = 3763) +#' ) +#' +#' head(osm_routes) #' #' @import dplyr #' @import sf -#' @import lwgeom +#' @importFrom rlang .data #' #' @export multiline_to_sorted_linestring <- function( @@ -68,6 +84,9 @@ multiline_to_sorted_linestring <- function( points = NULL, metric_crs = 3857 ) { + if (!requireNamespace("lwgeom", quietly = TRUE)) { + stop("Package 'lwgeom' is required for this function. Install it with: install.packages('lwgeom')") + } metric_crs_is_default <- missing(metric_crs) metric_crs <- suppressWarnings(sf::st_crs(metric_crs)) if (is.na(metric_crs)) { @@ -89,8 +108,8 @@ multiline_to_sorted_linestring <- function( st_set_geometry("geometry") |> st_transform(metric_crs) |> mutate( - start = lwgeom::st_startpoint(geometry), - end = lwgeom::st_endpoint(geometry) + start = lwgeom::st_startpoint(.data$geometry), + end = lwgeom::st_endpoint(.data$geometry) ) # 2. Reorder the linestrings by finding the best sequence @@ -106,9 +125,9 @@ multiline_to_sorted_linestring <- function( )) |> mutate(order = row_number()) |> st_transform(metric_crs) - start_point <- points_df |> slice(1) |> pull(geometry) + start_point <- points_df |> slice(1) |> pull(.data$geometry) if (length(points) > 1) { - second_point <- points_df |> slice(2) |> pull(geometry) + second_point <- points_df |> slice(2) |> pull(.data$geometry) } # Mark the first point as visited points_df$visited[1] <- TRUE @@ -124,6 +143,8 @@ multiline_to_sorted_linestring <- function( remaining_lines <- linestrings[-nearest_idx, ] } else { current_line <- linestrings[1, ] # Start with the first line + current_start <- lwgeom::st_startpoint(current_line$geometry) + current_end <- lwgeom::st_endpoint(current_line$geometry) remaining_lines <- linestrings[-1, ] } # Validate start segment orientation @@ -151,8 +172,10 @@ multiline_to_sorted_linestring <- function( if (st_distance(second_point, current_start) < st_distance(second_point, current_end)) { current_line$geometry <- st_reverse(current_line$geometry) } - } else if (st_distance(start_point, current_start) > st_distance(start_point, current_end)) { - current_line$geometry <- st_reverse(current_line$geometry) + } else if (!is.null(start_point)) { + if (st_distance(start_point, current_start) > st_distance(start_point, current_end)) { + current_line$geometry <- st_reverse(current_line$geometry) + } } } @@ -164,12 +187,12 @@ multiline_to_sorted_linestring <- function( while (nrow(remaining_lines) > 0) { if (!is.null(points_df)) { # Get index of the next point in points_df that has not been visited yet - next_point_index <- points_df |> filter(!visited) |> slice(1) |> pull(order) + next_point_index <- points_df |> filter(!.data$visited) |> slice(1) |> pull(.data$order) if (length(next_point_index) == 0) { next_point_index <- NULL next_point <- NULL } else { - next_point <- points_df |> filter(order == next_point_index) |> pull(geometry) + next_point <- points_df |> filter(.data$order == next_point_index) |> pull(.data$geometry) distance_to_next_point <- st_distance(current_line, next_point) } } @@ -249,12 +272,12 @@ multiline_to_sorted_linestring <- function( if (!is.null(points_df)) { # Mark consecutive next points as visited while current_line stays at least as close as any remaining line for the next unvisited point repeat { - next_unvisited <- points_df |> filter(!visited) |> slice(1) + next_unvisited <- points_df |> filter(!.data$visited) |> slice(1) if (nrow(next_unvisited) == 0) { break } - next_point_index <- next_unvisited |> pull(order) - next_point <- next_unvisited |> pull(geometry) + next_point_index <- next_unvisited |> pull(.data$order) + next_point <- next_unvisited |> pull(.data$geometry) distance_current_to_next <- as.numeric(st_distance(current_line, next_point)) distance_remaining_to_next <- if (nrow(remaining_lines) > 0) { min(as.numeric(st_distance(remaining_lines$geometry, next_point))) diff --git a/R/network_overline.R b/R/network_overline.R index 74c3480e..0e072eb9 100644 --- a/R/network_overline.R +++ b/R/network_overline.R @@ -17,25 +17,50 @@ #' segment, the overlapping lines and aggregates their \code{attr} values, using \code{fun}. #' #' -#' @returns A spatial object of the target network, extended with the aggregated values. +#' @returns sf. Spatial network object extended with aggregated values. #' #' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("https://operator.com/gtfs.zip") -#' target_network = st_read("network_centerlines.gpkg") -#' frequency_analysis <- GTFShift::get_route_frequency_hourly(gtfs, overline=FALSE) -#' GTFShift::network_overline( -#' target_network, -#' frequency_analysis |> filter(arrival_hour==8), -#' attr = "frequency" +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") #' ) -#' } +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("4", "1")) +#' +#' # Load OSM network to serve as target network +#' target_network = sf::st_read( +#' system.file("extdata/samples", "osm_ways_tcb.gpkg", package = "GTFShift"), +#' quiet = TRUE +#' ) +#' +#' head(target_network) +#' +#' # Get route frequency (and geometry) +#' frequency_analysis <- GTFShift::get_route_frequency_hourly( +#' gtfs, +#' date = gtfs$calendar$start_date[1] +#' ) |> +#' dplyr::group_by(shape_id) |> +#' dplyr::summarize(frequency = max(frequency)) +#' +#' head(frequency_analysis) +#' +#' # Aggregate frequencies based on geometry overlap using GTFShift::network_overline +#' suppressWarnings({ +#' overline <- GTFShift::network_overline( +#' target_network = target_network, +#' lines = frequency_analysis, +#' attr = "frequency", +#' metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +#' ) +#' }) +#' +#' head(overline |> st_drop_geometry()) #' #' @seealso \code{stplanr::rnet_join()} #' -#' @import stplanr #' @import sf #' @import dplyr +#' @importFrom rlang .data #' #' @export network_overline <- function( @@ -47,6 +72,9 @@ network_overline <- function( join_dist=10, metric_crs = 3857 ) { + if (!requireNamespace("stplanr", quietly = TRUE)) { + stop("Package 'stplanr' is required for this function. Install it with: install.packages('stplanr')") + } metric_crs_is_default <- missing(metric_crs) original_crs <- st_crs(target_network) metric_crs <- suppressWarnings(sf::st_crs(metric_crs)) @@ -77,10 +105,10 @@ network_overline <- function( mutate(df_id=row_number()) # 2. Overlap df and network segments - df_network_match = rnet_join( + df_network_match = stplanr::rnet_join( rnet_x = df, rnet_y = network_segmented |> - select(segment), + select("segment"), length_y = FALSE, key_column = "df_id", dist = join_dist, @@ -90,20 +118,20 @@ network_overline <- function( df_network_attr = df_network_match |> left_join(df |> st_drop_geometry() |> - select(attr, df_id), + select(all_of(attr), "df_id"), by = "df_id") # 3. Group attr by segment df_network_segment = df_network_attr |> - select(segment, attr) |> - group_by(segment) |> - summarise(!!attr := fun(frequency)) + select("segment", all_of(attr)) |> + group_by(.data$segment) |> + summarise(!!attr := fun(.data[[attr]])) # 4. Get geometry back result = network_segmented |> - filter(segment %in% df_network_segment$segment) |> + filter(.data$segment %in% df_network_segment$segment) |> left_join(df_network_segment, by="segment") |> - select(-segment) |> + select(-"segment") |> st_transform(crs = original_crs) return(result) diff --git a/R/osm_utils.R b/R/osm_utils.R index 26a71a07..1653032d 100644 --- a/R/osm_utils.R +++ b/R/osm_utils.R @@ -2,7 +2,7 @@ #' #' @param road_osm sf object. Road OSM data. #' -#' @return sf object. Filtered road OSM data. +#' @returns sf data.frame. Filtered road OSM data. #' #' @import dplyr #' @@ -16,7 +16,10 @@ filter_osm_bus_lanes <- function(road_osm) { if_any(any_of("psv"), ~ .x == "designated") | if_any(any_of("highway"), ~ .x == "busway") | if_any(any_of(cols_to_check_access), ~ grepl("designated", .x)) | - if_any(any_of(cols_to_check_count), ~ {v <- suppressWarnings(as.numeric(sub(";.*$", "", .x))); !is.na(v) & v >= 1}) + if_any(any_of(cols_to_check_count), ~ { + v <- suppressWarnings(as.numeric(sub(";.*$", "", .x))) + !is.na(v) & v >= 1 + }) ) return(osm_lanes) @@ -32,11 +35,11 @@ filter_osm_bus_lanes <- function(road_osm) { #' @param pb_update_3 numeric. Value to add to progress bar when progress at 3/4. #' @param pb_update_4 numeric. Value to add to progress bar when progress at 4/4. #' -#' @return data frame. OSM relations ways and nodes (with relation attributes) data frame with columns: `relation_osm_id`, `type`, `osm_id`, `role`, `gtfs:shape_id`, `gtfs:route_id`, `name`, `ref`, `roundtrip` +#' @returns data.frame. OSM relations ways and nodes (with relation attributes) data frame with columns: `relation_osm_id`, `type`, `osm_id`, `role`, `gtfs:shape_id`, `gtfs:route_id`, `name`, `ref`, `roundtrip` #' #' @noRd get_osm_relations <- function(osm_file, q, pb, osm_route_type = "bus", pb_update_1 = 0.25, pb_update_2 = 0.5, pb_update_3 = 0.75, pb_update_4 = 1) { - relations_pbf <- tempfile(fileext = ".osm.pbf") + relations_pbf <- withr::local_tempfile(fileext = ".osm.pbf") job <- callr::r_bg(function(relations_pbf, osm_file, osm_route_type) { # update spinner while blocking method call return(rosmium::tags_filter( @@ -81,7 +84,10 @@ get_osm_relations <- function(osm_file, q, pb, osm_route_type = "bus", pb_update rel_n <- 0 relations_data <- lapply(relations, function(rel) { rel_n <<- rel_n + 1 - pb$update(min(round(pb_update_3 + ((pb_update_4 - pb_update_3) * rel_n / length(relations)), digits = 2), 1)) + pb$update(min( + round(pb_update_3 + ((pb_update_4 - pb_update_3) * rel_n / length(relations)), digits = 2), + ifelse(rel_n < length(relations), 0.99, 1) # Prevent 0.9999 rounding to 1 before reaching last + )) tags <- xml2::xml_find_all(rel, ".//tag") tag_keys <- xml2::xml_attr(tags, "k") tag_vals <- xml2::xml_attr(tags, "v") @@ -112,22 +118,21 @@ get_osm_relations <- function(osm_file, q, pb, osm_route_type = "bus", pb_update return(NULL) } - data.frame( - # - relation_osm_id = xml2::xml_attr(rel, "id"), + members <- data.frame( # type = xml2::xml_attr(members, "type"), osm_id = xml2::xml_attr(members, "ref"), - role = xml2::xml_attr(members, "role"), - # - `gtfs:shape_id` = tag_vals["gtfs:shape_id"], - `gtfs:route_id` = tag_vals["gtfs:route_id"], - name = tag_vals["name"], - ref = tag_vals["ref"], - roundtrip = tag_vals["roundtrip"], - stringsAsFactors = FALSE, - check.names = FALSE + role = xml2::xml_attr(members, "role") ) + # + members["relation_osm_id"] <- xml2::xml_attr(rel, "id") + # + members["gtfs:shape_id"] <- tag_vals["gtfs:shape_id"] + members["gtfs:route_id"] <- tag_vals["gtfs:route_id"] + members["name"] <- tag_vals["name"] + members["ref"] <- tag_vals["ref"] + members["roundtrip"] <- tag_vals["roundtrip"] + return(members) }) relations_df <- dplyr::bind_rows(relations_data) diff --git a/R/prioritize_lanes.R b/R/prioritise_lanes.R similarity index 65% rename from R/prioritize_lanes.R rename to R/prioritise_lanes.R index 5360854c..92ced599 100644 --- a/R/prioritize_lanes.R +++ b/R/prioritise_lanes.R @@ -1,6 +1,6 @@ -#' Prioritize road network lanes for bus lane implementation +#' Prioritise road network lanes for bus lane implementation #' -#' For each OSM way with GTFS service, aggregates its characteristics to assist in the bus lane implementation prioritization +#' For each OSM way with GTFS service, aggregates its characteristics to assist in the bus lane implementation prioritisation #' #' @param gtfs tidygtfs. GTFS feed. #' @param q osmdata::opq. Overpass query for transit network, to obtain OSM route ways, using \code{GTFShift::osm_shapes_to_routes()}. @@ -10,7 +10,7 @@ #' #' @details #' This method analyses the GTFS feed for a representative day, returning a data.frame with the road segments where transit routes -#' run and for each, a set of parameters that can be used to prioritize bus lane implementations. +#' run and for each, a set of parameters that can be used to prioritise bus lane implementations. #' #' Its functionality is a bundle that encapsulates the logic of several methods from the package, #' including \code{GTFShift::get_way_frequency_hourly()} and \code{GTFShift::osm_bus_lanes()}, that can be used separately if needed. @@ -18,7 +18,7 @@ #' Mind that this method uses \code{GTFShift::get_way_frequency_hourly()} to match routes with OSM ways, which requires that the #' OSM relation mapping is well defined for the transit routes. Routes that do not have an OSM match are ignored. #' -#' @returns An \code{sf} \code{data.frame} object with the following columns: +#' @returns sf data.frame. Prioritised lanes with the following columns: #' \describe{ #' \item{way_osm_id}{The \code{osm_id} attribute from OSM way.} #' \item{hour}{The hour for which the frequency applies (24 hour format).} @@ -34,24 +34,36 @@ #' \item{(if \code{keep_osm_attributes = TRUE})}{All OSM way attributes.} #' } #' -#' @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") -#' -#' # To use OSM API: -#' lanes_analysis <- GTFShift::prioritize_lanes(gtfs, q) -#' -#' # To use a local OSM file: -#' osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -#' lanes_analysis <- GTFShift::prioritize_lanes(gtfs, q, osm_file = osm_file) -#' } -#' +#' @examplesIf nzchar(Sys.which("osmium")) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("4")) +#' +#' # Build query and prepare osm extract (possible to use API as alternative) +#' q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> +#' osmdata::add_osm_feature(key = "route", value = "bus") |> +#' osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +#' osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") +#' +#' lane_prioritisation <- GTFShift::prioritise_lanes( +#' gtfs, q, +#' osm_file = osm_file, +#' date = gtfs$calendar$start_date[1] +#' ) +#' +#' head( +#' lane_prioritisation |> +#' dplyr::select(way_osm_id, hour, frequency, is_bus_lane, n_lanes_circulation, routes) +#' ) +#' #' @import dplyr #' @import tidytransit +#' @importFrom rlang .data #' #' @export -prioritize_lanes <- function( +prioritise_lanes <- function( gtfs, q, date = GTFShift::calendar_nextBusinessWednesday(), @@ -62,7 +74,7 @@ prioritize_lanes <- function( way_frequency <- GTFShift::get_way_frequency_hourly(gtfs, q, date, TRUE, osm_file = osm_file) # Get bus lanes - bus_lanes <- filter_osm_bus_lanes(way_frequency |> distinct(way_osm_id, .keep_all = TRUE)) + bus_lanes <- filter_osm_bus_lanes(way_frequency |> distinct(.data$way_osm_id, .keep_all = TRUE)) # Aggregate data # > Add missing lanes columns, to prevent errors @@ -78,18 +90,18 @@ prioritize_lanes <- function( # > Compute aggregation lanes <- way_frequency |> - left_join(bus_lanes |> st_drop_geometry() |> select(way_osm_id) |> mutate(is_bus_lane = TRUE), by = "way_osm_id") |> + 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), + is_bus_lane = ifelse(is.na(.data$is_bus_lane), FALSE, .data$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(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( - # grepl "no" to account for parking:left:restriction=no_stopping - if_any(matches("^parking(:lane)?:left"), ~ !is.na(.) & !grepl("\\bno\\b|\\bno_", ., ignore.case = TRUE)) - ) + + as.integer( + # grepl "no" to account for parking:left:restriction=no_stopping + if_any(matches("^parking(:lane)?:left"), ~ !is.na(.) & !grepl("\\bno\\b|\\bno_", ., ignore.case = TRUE)) + ) + as.integer( if_any(matches("^parking(:lane)?:right"), ~ !is.na(.) & !grepl("\\bno\\b|\\bno_", ., ignore.case = TRUE)) ) @@ -97,21 +109,21 @@ prioritize_lanes <- function( ), n_lanes_circulation = coalesce( # Global count - parse_lanes(lanes), + parse_lanes(.data$lanes), # Directional count (sum existing ones; returns NA if all are missing) na_if( - rowSums(across(matches("^lanes(:[^:]+)*:forward$"), ~ coalesce(parse_lanes(.), 0)), na.rm = TRUE) + + rowSums(across(matches("^lanes(:[^:]+)*:forward$"), ~ coalesce(parse_lanes(.), 0)), na.rm = TRUE) + rowSums(across(matches("^lanes(:[^:]+)*:backward$"), ~ coalesce(parse_lanes(.), 0)), na.rm = TRUE) + rowSums(across(matches("^lanes(:[^:]+)*:both_ways$"), ~ coalesce(parse_lanes(.), 0)), na.rm = TRUE), 0 ), # If oneway=="yes", then 1 - ifelse(oneway == "yes", 1, NA_integer_), + ifelse(.data$oneway == "yes", 1, NA_integer_), # Else, assume 2 lanes, one per direction 2 # NA_integer_ ), n_directions = case_when( - n_lanes_circulation == 1 ~ 1, # When only one lane, assume one direction + .data$n_lanes_circulation == 1 ~ 1, # When only one lane, assume one direction # any oneway:* tag indicating "no" if_any(matches("oneway"), ~ tolower(.x) %in% c("no", "0", "false")) ~ 2, # any oneway:* tag indicating "yes" @@ -119,15 +131,15 @@ prioritize_lanes <- function( TRUE ~ 2 ), n_lanes_circulation_direction = case_when( - n_lanes_circulation / n_directions < 1 ~ 1, - !is.na(n_lanes_circulation) & !is.na(n_directions) ~ n_lanes_circulation / n_directions, + .data$n_lanes_circulation / .data$n_directions < 1 ~ 1, + !is.na(.data$n_lanes_circulation) & !is.na(.data$n_directions) ~ .data$n_lanes_circulation / .data$n_directions, TRUE ~ NA_real_ ) ) if (!keep_osm_attributes) { lanes <- lanes |> - select(way_osm_id, hour, frequency, is_bus_lane, n_lanes_parking, n_lanes_circulation, n_directions, n_lanes_circulation_direction, routes, shapes, geometry) + select("way_osm_id", "hour", "frequency", "is_bus_lane", "n_lanes_parking", "n_lanes_circulation", "n_directions", "n_lanes_circulation_direction", "routes", "shapes", "geometry") } return(lanes) diff --git a/R/project_points_along_geometry.R b/R/project_points_along_geometry.R index 491dd68c..7ee361c1 100644 --- a/R/project_points_along_geometry.R +++ b/R/project_points_along_geometry.R @@ -21,7 +21,7 @@ #' Distances are always computed in \code{metric_crs} units. The returned #' projected points are transformed back to the original \code{geometry} CRS. #' -#' @returns A data.frame with one row per input point and four columns: +#' @returns data.frame. Input points projected along geometry with four columns: #' \describe{ #' \item{closest_on_geometry}{An \code{sfc_POINT} column with the projected location on the line.} #' \item{distance_to_closest_on_geometry}{Numeric distance from each input point to its projected location on the line.} @@ -32,15 +32,31 @@ #' If \code{points} is empty, returns an empty data.frame with the same columns. #' #' @examples -#' \dontrun{ -#' line <- sf::st_sfc( -#' sf::st_linestring(matrix(c(0, 0, 100, 0, 200, 100), ncol = 2, byrow = TRUE)), -#' crs = 3857 +#' # Get sample points from GTFS-RT collection +#' rt_collect_file <- system.file( +#' "extdata/samples", "gtfs_rt_sample_tcb_4_4-CS-TERM.csv", package = "GTFShift" #' ) -#' pts <- sf::st_sfc(sf::st_point(c(20, 10)), sf::st_point(c(150, 40)), crs = 3857) -#' -#' projected <- project_points_along_geometry(line, pts, geometry_sample_meters = 5) -#' } +#' points <- read.csv(rt_collect_file) |> +#' sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) |> dplyr::sample_n(5) +#' +#' head(points |> dplyr::select(geometry)) +#' +#' # Get route geometry for points +#' osm_routes <- sf::st_read( +#' system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), +#' quiet = TRUE +#' ) |> dplyr::filter(route_id %in% points$route_id) +#' +#' head(osm_routes) +#' +#' # Project points to geometry +#' points_projected <- GTFShift::project_points_along_geometry( +#' geometry = osm_routes, +#' points = points, +#' metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +#' ) +#' +#' head(points_projected) #' #' @export project_points_along_geometry <- function( @@ -74,11 +90,12 @@ project_points_along_geometry <- function( stop("geometry must contain exactly one feature") } if (length(points_sfc) == 0) { - return(data.frame( + return(sf::st_sf( closest_on_geometry = points_sfc, distance_to_closest_on_geometry = numeric(0), distance_along_geometry = numeric(0), - distance_along_geometry_reversed = numeric(0) + distance_along_geometry_reversed = numeric(0), + sf_column_name = "closest_on_geometry" )) } @@ -95,13 +112,18 @@ project_points_along_geometry <- function( geometry_metric <- sf::st_transform(geometry_sfc, metric_crs) points_metric <- sf::st_transform(points_sfc, metric_crs) + if (geometry_type == "MULTILINESTRING") { + geom_merged <- sf::st_line_merge(geometry_metric) + geom_cast <- sf::st_cast(geom_merged, "LINESTRING") + geometry_metric <- sf::st_sfc(geom_cast[[1]], crs = metric_crs) + } + closest_points <- sf::st_nearest_points(points_metric, geometry_metric) closest_points_length <- sf::st_length(closest_points) pts_all <- sf::st_cast(closest_points, "POINT") closest_on_geometry_metric <- pts_all[seq(2, length(pts_all), by = 2)] closest_on_geometry <- sf::st_transform(closest_on_geometry_metric, geometry_crs_original) # mapview(closest_on_geometry) + mapview(closest_points) + mapview(geometry_sfc) - line_len_m <- as.numeric(sf::st_length(geometry_metric)) geometry_sampled <- sf::st_line_sample(geometry_metric, density = 1 / geometry_sample_meters) geometry_sampled_points <- sf::st_cast(geometry_sampled, "POINT") @@ -112,10 +134,11 @@ project_points_along_geometry <- function( distance_along_geometry <- cumdist_m[idx] distance_along_geometry_reversed <- cumdist_m_reversed[idx] - data.frame( + sf::st_sf( closest_on_geometry = closest_on_geometry, distance_to_closest_on_geometry = as.numeric(closest_points_length), distance_along_geometry = distance_along_geometry, - distance_along_geometry_reversed = distance_along_geometry_reversed + distance_along_geometry_reversed = distance_along_geometry_reversed, + sf_column_name = "closest_on_geometry" ) } diff --git a/R/query_mobilitydatabase.R b/R/query_mobilitydatabase.R index 795b43cc..d013d6cd 100644 --- a/R/query_mobilitydatabase.R +++ b/R/query_mobilitydatabase.R @@ -10,7 +10,7 @@ #' @param subdivision_name String (Optional). List only feeds with the specified value. Can be a partial match. #' @param municipality String (Optional). List only feeds with the specified value. Can be a partial match. Case insensitive. #' @param bbox bbox (Optional). Area from which to get GTFS feeds. Converted to API dataset_latitudes and dataset_longitudes URL parameters. -#' @param is_official. Boolean (Optional). If TRUE, only return official feeds. +#' @param is_official Boolean (Optional). If TRUE, only return official feeds. #' #' @details #' This method queries \href{https://mobilitydatabase.org/}{Mobility Database} API, allowing to get a list of GTFS feeds documented at this platform. @@ -24,34 +24,33 @@ #' \item{producer_url}{The GTFS feed URL. Can be used to download.} #' } #' -#' @returns data.frame with query results +#' @returns data.frame. Query results from Mobility Database. #' #' -#' @examples -#' \dontrun{ +#' @examplesIf nzchar(Sys.getenv("MOBILITY_DATABASE")) #' feeds <- GTFShift::query_mobilitydatabase( -#' refresh_token = "myToken", +#' refresh_token = Sys.getenv("MOBILITY_DATABASE"), #' country_code = "PT", #' is_official = TRUE #' ) -#' } +#' +#' head(feeds |> dplyr::select(id, provider, producer_url)) #' -#' @import httr +#' @importFrom httr GET POST add_headers content http_error http_status #' @import dplyr #' #' @export query_mobilitydatabase <- function(access_token = NA, - refresh_token = NA, - bounding_filter_method = "partially_enclosed", - limit = 10, - offset = 0, - country_code = NA, - subdivision_name = NA, - municipality = NA, - bbox = NA, - is_official = NA + refresh_token = NA, + bounding_filter_method = "partially_enclosed", + limit = 10, + offset = 0, + country_code = NA, + subdivision_name = NA, + municipality = NA, + bbox = NA, + is_official = NA ) { - # Validate parameters if (is.na(access_token) && is.na(refresh_token)) { stop("No token provided! At least one of the access or refresh tokens must be provided as an argument.") @@ -66,7 +65,7 @@ query_mobilitydatabase <- function(access_token = NA, body = body ) content <- content(response, as = "parsed") - if(http_error(response)) { + if (http_error(response)) { stop(sprintf("Mobility database bad response: %s", http_status(response))) } access_token <- content$access_token @@ -75,17 +74,19 @@ query_mobilitydatabase <- function(access_token = NA, # Query mobility database url <- "https://api.mobilitydatabase.org/v1/gtfs_feeds" - params <- list(bounding_filter_method = bounding_filter_method, - limit = limit, - offset = offset) - if (!is.na(country_code)) params["country_code"] = country_code - if (!is.na(subdivision_name)) params["subdivision_name"] = subdivision_name - if (!is.na(municipality)) params["municipality"] = municipality + params <- list( + bounding_filter_method = bounding_filter_method, + limit = limit, + offset = offset + ) + if (!is.na(country_code)) params["country_code"] <- country_code + if (!is.na(subdivision_name)) params["subdivision_name"] <- subdivision_name + if (!is.na(municipality)) params["municipality"] <- municipality if (!is.na(bbox)) { - params["dataset_latitudes"] = sprintf("%f,%f", bbox$ymin[[1]], bbox$ymax[[1]]) - params["dataset_longitudes"] = sprintf("%f,%f", bbox$xmin[[1]], bbox$xmax[[1]]) + params["dataset_latitudes"] <- sprintf("%f,%f", bbox$ymin[[1]], bbox$ymax[[1]]) + params["dataset_longitudes"] <- sprintf("%f,%f", bbox$xmin[[1]], bbox$xmax[[1]]) } - if (!is.na(is_official)) params["is_official"] = is_official + if (!is.na(is_official)) params["is_official"] <- is_official response <- GET( url, @@ -99,7 +100,7 @@ query_mobilitydatabase <- function(access_token = NA, # Convert response to data.frame content <- content(response, as = "parsed") - if(http_error(response)) { + if (http_error(response)) { stop(sprintf("Mobility database bad response: %s", http_status(response))) } diff --git a/R/query_osm_bus_lanes.R b/R/query_osm_bus_lanes.R index 513f247b..e4090dde 100644 --- a/R/query_osm_bus_lanes.R +++ b/R/query_osm_bus_lanes.R @@ -7,20 +7,27 @@ #' @details #' Exports roads tagged as designated bus lanes on OpenStreetMaps for given area. #' -#' @returns osm_lines in sf format +#' @returns sf data.frame. OSM bus lanes. #' #' #' @examples -#' \dontrun{ -#' BBOX <- sf::st_bbox(city_limit) -#' -#' # To use OSM API: -#' bus_lanes <- GTFShift::osm_bus_lanes(BBOX) -#' -#' # To use a local OSM file: -#' osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -#' bus_lanes <- GTFShift::osm_bus_lanes(BBOX, osm_file = osm_file) -#' } +#' # Create bbox for Lisbon +#' bbox <- sf::st_as_sfc(sf::st_bbox(c( +#' xmin = -9.229836, ymin = 38.691399, +#' xmax = -9.087387, ymax = 38.796760 +#' ), crs = 4326)) +#' +#' # Use sample osmextract for Lisbon highways +#' osm_file <- system.file( +#' "extdata/samples", "osmextract_lisbon_highways_sample.pbf", package = "GTFShift" +#' ) +#' +#' # Export bus lanes +#' bus_lanes <- GTFShift::osm_bus_lanes(bbox, osm_file = osm_file) +#' +#' names(bus_lanes) +#' +#' head(bus_lanes |> dplyr::select(`osm:id`, name)) #' #' @import osmdata #' @import sf diff --git a/R/query_osm_centerlines.R b/R/query_osm_centerlines.R index 5b1b3743..46336466 100644 --- a/R/query_osm_centerlines.R +++ b/R/query_osm_centerlines.R @@ -2,6 +2,7 @@ #' #' @param bbox bbox (Optional, if place provided). Area from which to export bus lanes. #' @param place String (Optional, if bbox provided). Place from which to export bus lanes. +#' @param osm_file String (Optional). Path to a local OpenStreetMap PBF file (`.pbf`). #' @param use_buildings Boolean (Default TRUE). Uses buildings from OSM as exclusion_mask for neatnet. #' @param venv String (Default creates a new one). Python environment where neatnet will run. #' @@ -9,25 +10,40 @@ #' Exports road network from OpenStreetMaps for given area and uses #' Python \href{https://uscuni.org/neatnet/}{neatnet} package to compute its centerlines. #' -#' One of \code{bbox} or \code{place} must be provided. If both, \code{bbox} is considered. +#' One of \code{bbox}, \code{place}, or \code{osm_file} must be provided. #' #' Parameter \code{use_buildings} exports building footprints from OSM for better results on #' the network simplification process. #' -#' @returns osm_lines in sf format +#' This method was adapted from \href{https://uscuni.org/neatnet/intro.html}{uscuni.org/neatnet} +#' by \href{https://github.com/miguelrelvaspires}{Miguel Relvas Pires} in the scope of +#' his \href{https://scholar.tecnico.ulisboa.pt/records/DhKWeFU5YLpMDcOhQbKR4f7ul05HCQnZr7ND}{master's thesis}. +#' The full code (Python) of his work is openly available at +#' \href{https://github.com/U-Shift/lp_streets}{GitHub}. #' -#' @examples -#' \dontrun{ -#' BBOX = sf::st_bbox(city_limit) -#' network <- GTFShift::osm_centerlines(BBOX) -#' } +#' @returns sf data.frame. OSM centerlines. #' -#' @import reticulate -#' @import sf +#' @examplesIf reticulate::py_module_available("neatnet") +#' # Get sample OSM extract +#' osm_file <- system.file("extdata/samples", "relation_6384187.pbf", package = "GTFShift") +#' +#' network <- GTFShift::osm_centerlines( +#' place = "Arroios, Lisboa, Portugal", +#' osm_file = osm_file +#' ) +#' +#' head(network) +#' +#' table(network$X_status) #' +#' @author \href{https://github.com/miguelrelvaspires}{Miguel Relvas Pires} +#' +#' @import sf #' @export -osm_centerlines <- function(bbox=NULL, place=NULL, use_buildings = TRUE, venv=NA) { - +osm_centerlines <- function(bbox = NULL, place = NULL, osm_file = NULL, use_buildings = TRUE, venv = NA) { + if (!requireNamespace("reticulate", quietly = TRUE)) { + stop("Package 'reticulate' is required for this function. Install it with: install.packages('reticulate')") + } # Set up Python environment if (is.na(venv)) { venv <- reticulate::virtualenv_create() @@ -35,15 +51,16 @@ osm_centerlines <- function(bbox=NULL, place=NULL, use_buildings = TRUE, venv=NA reticulate::use_virtualenv(venv, required = TRUE) # Ensure dependencies are installed - py_install(packages = c("osmnx", "pandas", "geopandas", "shapely", "neatnet"), pip = TRUE, pip_ignore_installed=FALSE) + reticulate::py_install(packages = c("osmnx", "pandas", "geopandas", "shapely", "neatnet", "pyrosm"), pip = TRUE, pip_ignore_installed = FALSE) # Define path to script and temp output py_script <- system.file("python", "osm_centerline_neatnet.py", package = "GTFShift") - temp_file <- tempfile(fileext = ".gpkg") + temp_file <- withr::local_tempfile(fileext = ".gpkg") # Call Python script via reticulate - reticulate::source_python(py_script) - get_centerline(bbox, place, use_buildings, temp_file) + py_env <- new.env() + reticulate::source_python(py_script, envir = py_env) + py_env$get_centerline(bbox, place, use_buildings, temp_file, osm_file) # Read the GPKG file as sf result <- sf::st_read(temp_file, quiet = TRUE) diff --git a/R/query_osm_shapes_match_routes.R b/R/query_osm_shapes_match_routes.R index 114ad9ba..15202ca3 100644 --- a/R/query_osm_shapes_match_routes.R +++ b/R/query_osm_shapes_match_routes.R @@ -66,7 +66,7 @@ #' an OSM one. This might generate wrong results if the topology of routes on OSM does not match the GTFS shapes for that route. #' Refer to \code{distance_diff}, \code{points_diff} and \code{stops_diff} on the results table to validate the results and identify misassociations. #' -#' @returns A \code{data.frame} (\code{sf} if \code{geometry=TRUE}) with the following columns: +#' @returns data.frame. Matched routes (\code{sf} if \code{geometry=TRUE}) with the following columns: #' \describe{ #' \item{route_id}{The \code{route_id} attribute from \code{routes.txt} file.} #' \item{shape_id}{The \code{shape_id} attribute from \code{shapes.txt} file.} @@ -81,31 +81,36 @@ #' \item{geometry}{The geometrical data for the OSM route relation.} #' } #' -#' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") +#' @examplesIf nzchar(Sys.which("osmium")) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", +#' package = "GTFShift" +#' )) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) #' -#' q <- opq("Lisbon") |> -#' add_osm_feature(key = "route", value = c("bus")) |> -#' add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) +#' # Build query and prepare osm extract (possible to use API as alternative) +#' q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> +#' osmdata::add_osm_feature(key = "route", value = "bus") |> +#' osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +#' osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") #' -#' # To use OSM API: -#' shapes_match_routes <- GTFShift::osm_shapes_match_routes(gtfs, q) +#' # Get OSM route geometries based on geometrical match +#' shapes_osm_routes <- GTFShift::osm_shapes_match_routes( +#' gtfs, q, +#' osm_file = osm_file, +#' metric_crs = 3763, # Make sure to addapt to the projection that better suits your location +#' ) #' -#' # To use a local OSM file: -#' osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -#' shapes_match_routes <- GTFShift::osm_shapes_match_routes(gtfs, q, osm_file = osm_file) -#' } +#' head(shapes_osm_routes |> dplyr::select(shape_id, osm_id, distance_diff, points_diff, stops_diff)) #' #' @import osmdata #' @import sf #' @import dplyr -#' @import stplanr -#' @import xml2 -#' @import progress -#' @import callr -#' @import stringi -#' @import parallel +#' @importFrom callr r_bg +#' @importFrom utils head tail +#' @importFrom xml2 read_xml xml_find_all xml_attr +#' @importFrom rlang .data #' #' @export osm_shapes_match_routes <- function( @@ -120,19 +125,19 @@ osm_shapes_match_routes <- function( metric_crs = 3857 ) { metric_crs_is_default <- missing(metric_crs) + initial_osm_file <- osm_file total_steps <- 4 if (!is.null(osm_file)) { total_steps <- 3 } - if (!is.na(log_file)) { + if (!is.null(log_file) && length(log_file) == 1 && !is.na(log_file)) { cat( sprintf("-----------------------------\n%s: Running osm_shapes_match_routes() for %s...\n\n", Sys.time(), paste(gtfs$agency$agency_name, collapse = ", ")), file = log_file, append = TRUE ) } - # 0. Validations if (!(gtfs_match %in% c("route_id", "route_short_name", "route_long_name"))) { stop("gtfs_match should be one of: route_id, route_short_name or route_long_name") } @@ -144,13 +149,18 @@ osm_shapes_match_routes <- function( stop("metric_crs should be a valid CRS value (e.g., 3857 or 'EPSG:3857')") } if (metric_crs_is_default) { + w <- "Using default metric_crs (EPSG:3857). Consider setting metric_crs to a projected CRS better suited to your local context for more accurate distance calculations." warning( - "Using default metric_crs (EPSG:3857). Consider setting metric_crs to a projected CRS better suited to your local context for more accurate distance calculations.", + w, call. = FALSE ) + if (!is.null(log_file) && length(log_file) == 1 && !is.na(log_file)) cat(paste("WARNING! ", w, "\n"), file = log_file, append = TRUE) } # 1. Get geometry for shapes and stops + if (!requireNamespace("progress", quietly = TRUE)) { + stop("Package 'progress' is required for this function. Install it with: install.packages('progress')") + } pb <- progress::progress_bar$new( # Track progress format = sprintf("1/%d: Preparing GTFS data [:bar] :percent :spin elapsed=:elapsed", total_steps), clear = FALSE, show_after = 0 @@ -192,33 +202,33 @@ osm_shapes_match_routes <- function( osm_ways <- osmextract::oe_read(osm_file, boundary = bbox, quiet = TRUE) pb$update(0.75) osm_multilines_redux <- relations_df |> - filter(type == "way") |> - select(relation_osm_id, osm_id, any_of(c("ref", "from", "to", "via", "name", "roundtrip", "gtfs:route_id", "gtfs:shape_id"))) |> + filter(.data$type == "way") |> + select("relation_osm_id", "osm_id", any_of(c("ref", "from", "to", "via", "name", "roundtrip", "gtfs:route_id", "gtfs:shape_id"))) |> # Join with osm_ways to get geometries back - left_join(osm_ways |> select(osm_id), by = "osm_id") |> - filter(!st_is_empty(geometry)) |> # Ignore empty geometries (for instance, platforms on railways) + left_join(osm_ways |> select("osm_id"), by = "osm_id") |> + filter(!st_is_empty(.data$geometry)) |> # Ignore empty geometries (for instance, platforms on railways) st_as_sf() |> # Group by osm_id, gtfs:shape_id, generating multilinestring with geometries dplyr::group_by(across(any_of(c("relation_osm_id", "ref", "name", "gtfs:shape_id", "gtfs:route_id", "roundtrip")))) |> dplyr::summarise(do_union = FALSE, .groups = "drop") |> sf::st_cast("MULTILINESTRING") |> - rename(osm_id = relation_osm_id) + rename(osm_id = .data$relation_osm_id) # 2.3 Get stop locations osm_stops <- osmextract::oe_read(osm_file, layer = "points", boundary = bbox, quiet = TRUE, extra_tags = c("public_transport")) |> - dplyr::filter(public_transport == "stop_position" | public_transport == "platform") |> - select(osm_id) + dplyr::filter(.data$public_transport == "stop_position" | .data$public_transport == "platform") |> + select("osm_id") pb$update(0.99) # Remove type==node that has osm_id not in osm_stops relations_df <- relations_df |> - filter(!(type == "node" & !(osm_id %in% osm_stops$osm_id))) |> - filter(relation_osm_id %in% osm_multilines_redux$osm_id) + filter(!(.data$type == "node" & !(.data$osm_id %in% osm_stops$osm_id))) |> + filter(.data$relation_osm_id %in% osm_multilines_redux$osm_id) osm_stoppositions <- relations_df |> - filter(type == "node") |> + filter(.data$type == "node") |> # Join with osm_stops to get geometries back - left_join(osm_stops |> select(osm_id), by = "osm_id") |> + left_join(osm_stops |> select("osm_id"), by = "osm_id") |> st_as_sf() pb$update(1) pb$terminate() @@ -227,7 +237,7 @@ osm_shapes_match_routes <- function( message(m) if (!is.na(log_file)) cat(paste(m, "\n"), file = log_file, append = TRUE) } else { - osm_file <- tempfile(fileext = ".osm", tmpdir = tempdir(check = TRUE)) + osm_file <- withr::local_tempfile(fileext = ".osm") job <- callr::r_bg(function(q, osm_file) { # update spinner while blocking method call osmdata::osmdata_xml(q, filename = osm_file, quiet = FALSE) }, args = list(q, osm_file)) @@ -251,7 +261,7 @@ osm_shapes_match_routes <- function( osm_multilines <- osm$osm_multilines osm_multilines_redux <- osm_multilines |> select(any_of(c("osm_id", "ref", "from", "to", "via", "name", "roundtrip", "gtfs:route_id"))) |> - distinct(osm_id, .keep_all = TRUE) + distinct(.data$osm_id, .keep_all = TRUE) pb$update(0.66) st_agr(osm$osm_points) <- "constant" # https://github.com/r-spatial/sf/issues/406 @@ -259,7 +269,7 @@ osm_shapes_match_routes <- function( return( osm$osm_points |> sf::st_crop(sf::st_bbox(stplanr::geo_buffer(osm_multilines_redux, dist = 100))) |> - dplyr::filter(public_transport == "stop_position" | public_transport == "platform") |> + dplyr::filter(.data$public_transport == "stop_position" | .data$public_transport == "platform") |> dplyr::select_if(~ !all(is.na(.))) ) }, args = list(osm, osm_multilines_redux)) @@ -274,7 +284,7 @@ osm_shapes_match_routes <- function( # 4. Processing OSM relations (already have the file!) - if (is.null(osm_file)) { + if (is.null(initial_osm_file)) { pb <- progress::progress_bar$new( format = sprintf("3/%d: Processing OSM relations [:bar] :percent :spin elapsed=:elapsed", total_steps), clear = FALSE, show_after = 0 @@ -282,8 +292,8 @@ osm_shapes_match_routes <- function( pb$update(0) job <- callr::r_bg(function(osm_file) { # update spinner while blocking method call - library(xml2) - library(dplyr) + requireNamespace("xml2", quietly = TRUE) + requireNamespace("dplyr", quietly = TRUE) doc <- read_xml(osm_file) relations <- xml_find_all(doc, ".//relation") @@ -331,16 +341,16 @@ osm_shapes_match_routes <- function( warning_osm_stops_missing <- list() stop_counts <- relations_df |> - dplyr::filter(grepl("stop|platform", role)) |> - dplyr::group_by(relation_osm_id) |> + dplyr::filter(grepl("stop|platform", .data$role)) |> + dplyr::group_by(.data$relation_osm_id) |> dplyr::summarise( - nr_s = sum(grepl("stop", role)), - nr_p = sum(grepl("platform", role)), - nr_stops = max(nr_s, nr_p) + nr_s = sum(grepl("stop", .data$role)), + nr_p = sum(grepl("platform", .data$role)), + nr_stops = max(.data$nr_s, .data$nr_p) ) match_route_worker <- function(route_name) { - # message("route_name = " %>% paste(route_name)) + # message("route_name = " |> paste(route_name)) # Warning records for this specific route warn_routes_missing <- list() warn_osm_repeated <- list() @@ -354,6 +364,9 @@ osm_shapes_match_routes <- function( dplyr::filter(.data[[osm_match]] == route_name) } else { words <- tolower(strsplit(route_name, "\\s+")[[1]]) + if (!requireNamespace("stringi", quietly = TRUE)) { + stop("Package 'stringi' is required for non-exact route matching. Install it with: install.packages('stringi')") + } words_norm <- stringi::stri_trans_general(words, "Latin-ASCII") osm_route_name <- osm_multilines_redux |> dplyr::filter( @@ -383,7 +396,7 @@ osm_shapes_match_routes <- function( osm_route_error <- FALSE for (i in 1:nrow(osm_route_name)) { # Validate that if OSM route has entry/exit stops, they respect the right order route <- osm_route_name[i, ] - relation_df <- relations_df |> dplyr::filter(type == "node" & relation_osm_id == route$osm_id) + relation_df <- relations_df |> dplyr::filter(.data$type == "node" & .data$relation_osm_id == route$osm_id) entry_rows <- grep("entry", relation_df$role, ignore.case = TRUE) exit_rows <- grep("exit", relation_df$role, ignore.case = TRUE) if (length(entry_rows) > 0) { # If entry row exists, validate that is first @@ -413,12 +426,12 @@ osm_shapes_match_routes <- function( # > Filter GTFS gtfs_route_name <- gtfs$routes |> # Start on routes.txt to match line number with route_name - dplyr::select(route_id, route_short_name, route_long_name) |> + dplyr::select("route_id", "route_short_name", "route_long_name") |> dplyr::filter(.data[[gtfs_match]] == route_name) |> - dplyr::left_join(gtfs$trips |> dplyr::select(route_id, trip_id, shape_id, direction_id), by = "route_id") |> - dplyr::filter(!is.na(trip_id)) |> + dplyr::left_join(gtfs$trips |> dplyr::select("route_id", "trip_id", "shape_id", "direction_id"), by = "route_id") |> + dplyr::filter(!is.na(.data$trip_id)) |> dplyr::left_join(shapes_sf, by = "shape_id") |> - dplyr::distinct(shape_id, .keep_all = TRUE) |> + dplyr::distinct(.data$shape_id, .keep_all = TRUE) |> sf::st_as_sf() if (nrow(gtfs_route_name) == 0) { # In case route does not have trips, nor shapes (no need to log error, as it had no geometries anyway) return(list( @@ -433,72 +446,89 @@ osm_shapes_match_routes <- function( # 2. Match based on initial and final points # > Compute osm final and initial points geom_col <- sf::st_geometry(osm_route_name |> st_transform(metric_crs)) # To get route length in a projected CRS - + osm_route_name <- tryCatch( { osm_route_name |> dplyr::mutate( - roundtrip = if (!"roundtrip" %in% names(osm_route_name)) NA else roundtrip, - route_dist = sf::st_length(geom_col) |> units::drop_units() + roundtrip = if (!"roundtrip" %in% names(osm_route_name)) NA else .data$roundtrip, + route_dist = as.numeric(sf::st_length(geom_col)) ) |> dplyr::rowwise() |> dplyr::left_join(stop_counts, by = c("osm_id" = "relation_osm_id")) |> dplyr::mutate( - # Geographical data - # Other relevant parameters, - first_stop_osm_id = relations_df |> - dplyr::filter(type == "node") |> - dplyr::select(relation_osm_id, stop_osm_id = osm_id, role) |> - # Consider both stop_entry/exit_only and stop, because circular lines do not have entry/exit, only stop - dplyr::filter(relation_osm_id == osm_id & role %in% c("stop_entry_only", "stop", "platform_entry_only", "platform")) |> - # Filter out stops/platforms if that type is underrepresented (if ratio is higher than 3, ignore that type) - dplyr::filter( - (nr_s > 3 * nr_p & role %in% c("stop_entry_only", "stop")) | - (nr_p > 3 * nr_s & role %in% c("platform_entry_only", "platform")) | - (nr_s <= 3 * nr_p & nr_p <= 3 * nr_s) - ) |> - # Use sorting to give priority to entry/exit, when they exist - dplyr::arrange( - match(role, c("stop_entry_only", "platform_entry_only", "stop", "platform")), - role - ) |> - dplyr::slice(1) |> - dplyr::pull(stop_osm_id), - last_stop_osm_id = relations_df |> - dplyr::filter(type == "node") |> - dplyr::select(relation_osm_id, stop_osm_id = osm_id, role) |> - dplyr::filter(relation_osm_id == osm_id & role %in% c("stop_exit_only", "stop", "platform_exit_only", "platform")) |> - # Filter out stops/platforms if that type is underrepresented (if ratio is higher than 3, ignore that type) - dplyr::filter( - (nr_s > 3 * nr_p & role %in% c("stop_exit_only", "stop")) | - (nr_p > 3 * nr_s & role %in% c("platform_exit_only", "platform")) | - (nr_s <= 3 * nr_p & nr_p <= 3 * nr_s) - ) |> - dplyr::mutate(role_group = dplyr::case_when( - # When roundtrip (circular), keep normal order - roundtrip == "yes" ~ 1, - # Otherwise, consider last stop_exit_only or stop (if no exit_only) - role == "stop_exit_only" ~ 1, role == "platform_exit_only" ~ 2, role == "stop" ~ 4, role == "platform" ~ 4, TRUE ~ 5 - )) |> - dplyr::arrange( - role_group, # First criteria, to prioritize entry/exit when they exist - dplyr::case_when( # Within each role, sort by order on OSM relation, considering roundtrip and role type - roundtrip == "yes" ~ dplyr::row_number(), # When roundtrip (circular), keep normal order - role == "stop_exit_only" ~ dplyr::desc(dplyr::row_number()), # reverse order - role == "platform_exit_only" ~ dplyr::desc(dplyr::row_number()), # reverse order - role == "stop" ~ dplyr::desc(dplyr::row_number()), # reverse order - role == "platform" ~ dplyr::desc(dplyr::row_number()), # reverse order - TRUE ~ dplyr::desc(dplyr::row_number()) # fallback order for others - ) - ) |> - dplyr::slice(1) |> - dplyr::pull(stop_osm_id), - initial = osm_stoppositions |> dplyr::filter(osm_id == first_stop_osm_id) |> dplyr::slice(1) |> dplyr::pull(geometry) |> dplyr::first(default = NA), - final = osm_stoppositions |> dplyr::filter(osm_id == last_stop_osm_id) |> dplyr::slice(1) |> dplyr::pull(geometry) |> dplyr::first(default = NA) + first_stop_osm_id = { + rel_id <- .data$osm_id + ns <- .data$nr_s + np <- .data$nr_p + relations_df |> + dplyr::filter(.data$type == "node") |> + dplyr::select(relation_osm_id = "relation_osm_id", stop_osm_id = "osm_id", role = "role") |> + dplyr::filter(.data$relation_osm_id == rel_id & .data$role %in% c("stop_entry_only", "stop", "platform_entry_only", "platform")) |> + dplyr::filter( + (ns > 3 * np & .data$role %in% c("stop_entry_only", "stop")) | + (np > 3 * ns & .data$role %in% c("platform_entry_only", "platform")) | + (ns <= 3 * np & np <= 3 * ns) + ) |> + dplyr::arrange( + match(.data$role, c("stop_entry_only", "platform_entry_only", "stop", "platform")), + .data$role + ) |> + dplyr::slice(1) |> + dplyr::pull(.data$stop_osm_id) + }, + last_stop_osm_id = { + rel_id <- .data$osm_id + ns <- .data$nr_s + np <- .data$nr_p + rt <- .data$roundtrip + relations_df |> + dplyr::filter(.data$type == "node") |> + dplyr::select(relation_osm_id = "relation_osm_id", stop_osm_id = "osm_id", role = "role") |> + dplyr::filter(.data$relation_osm_id == rel_id & .data$role %in% c("stop_exit_only", "stop", "platform_exit_only", "platform")) |> + dplyr::filter( + (ns > 3 * np & .data$role %in% c("stop_exit_only", "stop")) | + (np > 3 * ns & .data$role %in% c("platform_exit_only", "platform")) | + (ns <= 3 * np & np <= 3 * ns) + ) |> + dplyr::mutate(role_group = dplyr::case_when( + isTRUE(rt == "yes") ~ 1, + .data$role == "stop_exit_only" ~ 1, .data$role == "platform_exit_only" ~ 2, .data$role == "stop" ~ 4, .data$role == "platform" ~ 4, TRUE ~ 5 + )) |> + dplyr::arrange( + .data$role_group, + dplyr::case_when( + isTRUE(rt == "yes") ~ dplyr::row_number(), + .data$role == "stop_exit_only" ~ dplyr::desc(dplyr::row_number()), + .data$role == "platform_exit_only" ~ dplyr::desc(dplyr::row_number()), + .data$role == "stop" ~ dplyr::desc(dplyr::row_number()), + .data$role == "platform" ~ dplyr::desc(dplyr::row_number()), + TRUE ~ dplyr::desc(dplyr::row_number()) + ) + ) |> + dplyr::slice(1) |> + dplyr::pull(.data$stop_osm_id) + }, + initial = { + stop_osm_id <- .data$first_stop_osm_id + osm_stoppositions |> + dplyr::filter(.data$osm_id == stop_osm_id) |> + dplyr::slice(1) |> + dplyr::pull(.data$geometry) |> + dplyr::first(default = NA) + }, + final = { + stop_osm_id <- .data$last_stop_osm_id + osm_stoppositions |> + dplyr::filter(.data$osm_id == stop_osm_id) |> + dplyr::slice(1) |> + dplyr::pull(.data$geometry) |> + dplyr::first(default = NA) + } ) |> dplyr::ungroup() |> - dplyr::select(osm_id, ref, name, route_dist, nr_stops, first_stop_osm_id, last_stop_osm_id, initial, final, geometry) |> - dplyr::arrange(route_dist) + dplyr::select("osm_id", "ref", "name", "route_dist", "nr_stops", "first_stop_osm_id", "last_stop_osm_id", "initial", "final", "geometry") |> + dplyr::arrange(.data$route_dist) }, error = function(e) { warn_osm_stops_missing <- append(warn_osm_stops_missing, sprintf("`osm_id` %s (`%s` %s)", paste(osm_route_name$osm_id, collapse = ", "), gtfs_match, route_name)) @@ -518,27 +548,57 @@ osm_shapes_match_routes <- function( # > Same for GTFS shapes geom_col <- sf::st_geometry(gtfs_route_name |> st_transform(metric_crs)) # To get route length in a projected CRS gtfs_route_name <- gtfs_route_name |> - dplyr::mutate(route_dist = sf::st_length(geom_col) |> units::drop_units()) |> + dplyr::mutate(route_dist = as.numeric(sf::st_length(geom_col))) |> dplyr::rowwise() |> dplyr::mutate( # Geographical data - trip_id_copy = trip_id, - first_stop_id = gtfs$stop_times |> dplyr::filter(trip_id == trip_id_copy) |> dplyr::arrange(stop_sequence) |> dplyr::slice(1) |> dplyr::pull(stop_id), - last_stop_id = gtfs$stop_times |> dplyr::filter(trip_id == trip_id_copy) |> dplyr::arrange(dplyr::desc(stop_sequence)) |> dplyr::slice(1) |> dplyr::pull(stop_id), - initial = stops_sf |> dplyr::filter(stop_id == first_stop_id) |> dplyr::slice(1) |> dplyr::pull(geometry), - final = stops_sf |> dplyr::filter(stop_id == last_stop_id) |> dplyr::slice(1) |> dplyr::pull(geometry), - + first_stop_id = { + route_trip_id <- .data$trip_id + gtfs$stop_times |> + dplyr::filter(.data$trip_id == route_trip_id) |> + dplyr::arrange(.data$stop_sequence) |> + dplyr::slice(1) |> + dplyr::pull(.data$stop_id) + }, + last_stop_id = { + route_trip_id <- .data$trip_id + gtfs$stop_times |> + dplyr::filter(.data$trip_id == route_trip_id) |> + dplyr::arrange(dplyr::desc(.data$stop_sequence)) |> + dplyr::slice(1) |> + dplyr::pull(.data$stop_id) + }, # Other relevant parameters - nr_stops = nrow(gtfs$stop_times |> dplyr::filter(trip_id == trip_id_copy)) + nr_stops = { + route_trip_id <- .data$trip_id + nrow(gtfs$stop_times |> dplyr::filter(.data$trip_id == route_trip_id)) + } + ) |> + mutate( + initial = { + init_stop_id <- .data$first_stop_id + stops_sf |> + dplyr::filter(.data$stop_id == init_stop_id) |> + dplyr::slice(1) |> + dplyr::pull(.data$geometry) + }, + final = { + fin_stop_id <- .data$last_stop_id + stops_sf |> + dplyr::filter(.data$stop_id == fin_stop_id) |> + dplyr::slice(1) |> + dplyr::pull(.data$geometry) + } ) |> dplyr::ungroup() |> - dplyr::select(-trip_id_copy) |> - dplyr::arrange(route_dist, initial, final) + dplyr::arrange(.data$route_dist, .data$initial, .data$final) # 3. Match gtfs shapes and osm routes, by choosing the one that share the closest start and end points # > Compute distances between init and final points for both - init <- units::drop_units(sf::st_distance(osm_route_name$initial |> st_transform(metric_crs), gtfs_route_name$initial |> st_transform(metric_crs))) - fin <- units::drop_units(sf::st_distance(osm_route_name$final |> st_transform(metric_crs), gtfs_route_name$final |> st_transform(metric_crs))) + init_dist <- sf::st_distance(osm_route_name$initial |> st_transform(metric_crs), gtfs_route_name$initial |> st_transform(metric_crs)) + fin_dist <- sf::st_distance(osm_route_name$final |> st_transform(metric_crs), gtfs_route_name$final |> st_transform(metric_crs)) + init <- matrix(as.numeric(init_dist), nrow = nrow(init_dist), ncol = ncol(init_dist)) + fin <- matrix(as.numeric(fin_dist), nrow = nrow(fin_dist), ncol = ncol(fin_dist)) length_diff <- sapply(gtfs_route_name$route_dist, function(y) abs(osm_route_name$route_dist - y)) # Proxy for number of stops distance: average distance between stops on GTFS, times the difference between osm and gtfs stops stops_diff <- sapply( @@ -551,36 +611,40 @@ osm_shapes_match_routes <- function( # > Match OSM network and GTFS shapes considering the match with min aggregated distance (init + fin) closeness <- abs(init + fin + length_diff + stops_diff) + if (!is.matrix(closeness)) { + closeness <- matrix(closeness, nrow = nrow(osm_route_name), ncol = nrow(gtfs_route_name)) + } gtfs_route_name_minimos <- gtfs_route_name |> dplyr::mutate(osm_id = NA) for (i in 1:nrow(gtfs_route_name_minimos)) { - gtfs_route_name_minimos[i, ]$osm_id <- osm_route_name[which.min(closeness[, i]), ]$osm_id + gtfs_route_name_minimos[i, ]$osm_id <- osm_route_name[which.min(closeness[, i, drop = TRUE]), ]$osm_id } gtfs_route_name_result <- gtfs_route_name_minimos |> sf::st_drop_geometry() |> dplyr::left_join( - osm_route_name |> dplyr::select(osm_id, name, ref, route_dist, nr_stops, geometry, initial, final) |> dplyr::rename(osm_name = name, osm_ref = ref), + osm_route_name |> dplyr::select("osm_id", "name", "ref", "route_dist", "nr_stops", "geometry", "initial", "final") |> + dplyr::rename(osm_name = .data$name, osm_ref = .data$ref), by = "osm_id", suffix = c("_gtfs", "_osm") ) |> dplyr::rowwise() |> dplyr::mutate( - distance_diff = abs(route_dist_gtfs - route_dist_osm), - points_diff = as.numeric(units::drop_units(sf::st_distance(initial_osm |> st_transform(metric_crs), initial_gtfs |> st_transform(metric_crs)))) + units::drop_units(sf::st_distance(final_osm |> st_transform(metric_crs), final_gtfs |> st_transform(metric_crs))), - stops_diff = abs(nr_stops_gtfs - nr_stops_osm) + distance_diff = as.numeric(abs(.data$route_dist_gtfs - .data$route_dist_osm)), + points_diff = as.numeric(sf::st_distance(.data$initial_osm |> st_transform(metric_crs), .data$initial_gtfs |> st_transform(metric_crs))) + as.numeric(sf::st_distance(.data$final_osm |> st_transform(metric_crs), .data$final_gtfs |> st_transform(metric_crs))), + stops_diff = as.numeric(abs(.data$nr_stops_gtfs - .data$nr_stops_osm)) ) |> # absolute difference dplyr::ungroup() |> - dplyr::select(-initial_gtfs, -final_gtfs) |> + dplyr::select(-"initial_gtfs", -"final_gtfs") |> sf::st_as_sf(sf_column_name = "geometry") # When multiple osm_id, return those with min distance_diff + points_diff + then stops_diff if (length(unique(gtfs_route_name_result$osm_id)) < nrow(gtfs_route_name_result)) { gtfs_route_name_result_unique <- gtfs_route_name_result |> - dplyr::group_by(osm_id) |> - dplyr::slice_min(order_by = distance_diff + points_diff + stops_diff, with_ties = FALSE) |> + dplyr::group_by(.data$osm_id) |> + dplyr::slice_min(order_by = .data$distance_diff + .data$points_diff + .data$stops_diff, with_ties = FALSE) |> dplyr::ungroup() warn_osm_repeated <- append(warn_osm_repeated, sprintf( @@ -623,6 +687,9 @@ osm_shapes_match_routes <- function( message(m) if (!is.na(log_file)) cat(paste(m, "\n"), file = log_file, append = TRUE) + if (!requireNamespace("parallel", quietly = TRUE)) { + stop("Package 'parallel' is required for multi-core processing. Install it with: install.packages('parallel')") + } results_list <- parallel::mclapply(routes_names, match_route_worker, mc.cores = num_cores) } else { results_list <- lapply(routes_names, function(route_name) { @@ -658,12 +725,12 @@ osm_shapes_match_routes <- function( dplyr::left_join( osm_multilines_redux |> sf::st_drop_geometry() |> - dplyr::select(osm_id, osm_name = name, osm_ref = ref) |> - dplyr::distinct(osm_id, .keep_all = TRUE), + dplyr::select(osm_id = "osm_id", osm_name = "name", osm_ref = "ref") |> + dplyr::distinct(.data$osm_id, .keep_all = TRUE), by = "osm_id" ) |> dplyr::left_join( - osm_multilines_redux |> dplyr::select(osm_id, geometry), + osm_multilines_redux |> dplyr::select("osm_id", "geometry"), by = "osm_id" ) |> sf::st_as_sf() @@ -686,7 +753,7 @@ osm_shapes_match_routes <- function( # > Output success message if (nrow(result_success) > 0) { result_success <- result_success |> left_join(route_shapes |> select( - -any_of(names(result_success)), shape_id # Avoid duplicate columns + -any_of(names(result_success)), "shape_id" # Avoid duplicate columns ), by = "shape_id") m <- sprintf( "> Associated %d shapes (%.2f%% of %d total) of %d routes (%.2f%% of %d total) with OSM routes, corresponding to %d trips (%.2f%% of %d total), with a mean distance of %.2f meters for points, %.2f meters for route length and a mean difference of %.2f stops\n", @@ -695,8 +762,8 @@ osm_shapes_match_routes <- function( nrow(result_success) / nrow(shapes_sf) * 100, nrow(shapes_sf), # routes - nrow(result_success |> distinct(route_id)), - nrow(result_success |> distinct(route_id)) / length(unique(gtfs$routes$route_id)) * 100, + nrow(result_success |> distinct(.data$route_id)), + nrow(result_success |> distinct(.data$route_id)) / length(unique(gtfs$routes$route_id)) * 100, length(unique(gtfs$routes$route_id)), # trips sum(result_success$n_trips), @@ -712,8 +779,8 @@ osm_shapes_match_routes <- function( m <- sprintf( "> Of those, %d shapes (%.2f%% of %d matched) have a distance difference below 1000 meters AND a points difference below 500 meters\n", - nrow(result_success |> filter(distance_diff < 1000 & points_diff < 500)), - nrow(result_success |> filter(distance_diff < 1000 & points_diff < 500)) / nrow(result_success) * 100, + nrow(result_success |> filter(.data$distance_diff < 1000 & .data$points_diff < 500)), + nrow(result_success |> filter(.data$distance_diff < 1000 & .data$points_diff < 500)) / nrow(result_success) * 100, nrow(result_success) ) message(m) @@ -723,11 +790,11 @@ osm_shapes_match_routes <- function( # > Output error messages not_found <- bind_rows(result[lengths(result) <= 1]) routes_shapes_n <- gtfs$routes |> # Start on routes.txt to match line number with route_name - select(route_id, !!gtfs_match) |> - left_join(gtfs$trips |> select(route_id, trip_id, shape_id, direction_id), by = "route_id") |> - filter(!is.na(trip_id)) |> # Ignore routes without trips, because they do not have shapes, so they are not expected to be matched with OSM routes (and thus, not expected to be in the results, so no need to log them as errors) + select("route_id", !!gtfs_match) |> + left_join(gtfs$trips |> select("route_id", "trip_id", "shape_id", "direction_id"), by = "route_id") |> + filter(!is.na(.data$trip_id)) |> # Ignore routes without trips, because they do not have shapes, so they are not expected to be matched with OSM routes (and thus, not expected to be in the results, so no need to log them as errors) left_join(shapes_sf, by = "shape_id") |> - distinct(.data[[gtfs_match]], shape_id) |> + distinct(.data[[gtfs_match]], .data$shape_id) |> group_by(.data[[gtfs_match]]) |> summarise(shapes_n = n()) partial_match <- result_success |> @@ -737,8 +804,8 @@ osm_shapes_match_routes <- function( group_by(.data[[gtfs_match]]) |> summarise(shapes_n = n()) |> left_join(routes_shapes_n, by = gtfs_match) |> - rename(matched = shapes_n.x, gtfs = shapes_n.y) |> - filter(matched < gtfs) + rename(matched = .data$shapes_n.x, gtfs = .data$shapes_n.y) |> + filter(.data$matched < .data$gtfs) } warning_osm_unsorted_stops <- unique(warning_osm_unsorted_stops) # This warning list can have duplicates, ignore diff --git a/R/query_osm_shapes_to_routes.R b/R/query_osm_shapes_to_routes.R index f3552b02..b269dbc4 100644 --- a/R/query_osm_shapes_to_routes.R +++ b/R/query_osm_shapes_to_routes.R @@ -11,7 +11,7 @@ #' For each route, matches its trips' shapes with OSM route relations, considering the #' OSM \code{gtfs:shape_id} attribute. #' -#' @returns A \code{sf} \code{data.frame} with the following columns: +#' @returns sf data.frame. Matched shape to route geometries with the following columns: #' \describe{ #' \item{shape_id}{The \code{shape_id} attribute from \code{shapes.txt} file.} #' \item{osm_id}{The \code{osm_id} attribute from OSM route relation.} @@ -23,26 +23,45 @@ #' Shapes that do not have a match on OSM are ignored. #' If that occurs, a warning is displayed during the method execution, informing about the missing geometries. #' -#' @examples -#' \dontrun{ -#' gtfs <- GTFShift::load_feed("gtfs.zip") +#' @examplesIf nzchar(Sys.which("osmium")) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) #' -#' q <- opq("Lisbon") |> -#' add_osm_feature(key = "route", value = c("bus")) |> -#' add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) +#' # Build query and prepare osm extract (possible to use API as alternative) +#' q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> +#' osmdata::add_osm_feature(key = "route", value = "bus") |> +#' osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +#' osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") #' -#' # To use OSM API: -#' shapes_geometry_osm <- GTFShift::osm_shapes_to_routes(gtfs, q) +#' # Get OSM route geometries based on gtfs:shape_id match +#' shapes_osm_routes <- GTFShift::osm_shapes_to_routes( +#' gtfs, q, +#' osm_file = osm_file +#' ) #' -#' # To use a local OSM file: -#' osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -#' shapes_geometry_osm <- GTFShift::osm_shapes_to_routes(gtfs, q, osm_file = osm_file) -#' } +#' head(shapes_osm_routes |> dplyr::select(shape_id, osm_id)) +#' +#' nrow(shapes_osm_routes) +#' +#' # Get OSM ways instead +#' shapes_osm_ways <- GTFShift::osm_shapes_to_routes( +#' gtfs, q, +#' osm_file = osm_file, +#' ways = TRUE +#' ) +#' +#' head(shapes_osm_ways |> dplyr::select(way_osm_id, shape_id, osm_id)) +#' +#' nrow(shapes_osm_ways) +#' #' @import osmdata #' @import sf #' @import dplyr -#' @import progress -#' @import callr +#' @importFrom callr r_bg +#' @importFrom rlang .data #' #' @export osm_shapes_to_routes <- function( @@ -59,6 +78,9 @@ osm_shapes_to_routes <- function( osm_ways <- NULL # 1. Fetch OSM data as XML + if (!requireNamespace("progress", quietly = TRUE)) { + stop("Package 'progress' is required for this function. Install it with: install.packages('progress')") + } pb <- progress::progress_bar$new( # Track progress format = sprintf( ifelse( @@ -72,32 +94,34 @@ osm_shapes_to_routes <- function( ) pb$update(0) + initial_osm_file <- osm_file if (!is.null(osm_file)) { # 1.1. Get relations relations_df <- get_osm_relations(osm_file, q, pb, osm_route_type, 0.1, 0.2, 0.3, 0.94) |> - filter(type == "way") |> - rename(way_osm_id = osm_id, osm_id = relation_osm_id) + filter(.data$type == "way") |> + rename(way_osm_id = .data$osm_id, osm_id = .data$relation_osm_id) # 1.3. Get geometries and filter by matched relations bbox <- st_bbox(tidytransit::shapes_as_sf(gtfs$shapes)) osm_ways <- osmextract::oe_read(osm_file, boundary = bbox, quiet = TRUE) pb$update(0.95) osm_multilines_redux <- relations_df |> - select(osm_id, way_osm_id, `gtfs:shape_id`) |> + select("osm_id", "way_osm_id", "gtfs:shape_id") |> # Join with osm_ways to get geometries back - left_join(osm_ways |> select(osm_id), by = c("way_osm_id" = "osm_id")) |> + left_join(osm_ways |> select("osm_id"), by = c("way_osm_id" = "osm_id")) |> st_as_sf() if (!ways) { # Group by osm_id, gtfs:shape_id, generating multilinestring with geometries pb$update(0.99) osm_multilines_redux <- osm_multilines_redux |> - dplyr::group_by(osm_id, `gtfs:shape_id`) |> + dplyr::group_by(.data$osm_id, .data$`gtfs:shape_id`) |> dplyr::summarise(do_union = FALSE, .groups = "drop") |> sf::st_cast("MULTILINESTRING") } } else { - osm_file <- tempfile(fileext = ".osm", tmpdir = tempdir(check = TRUE)) + osm_file <- withr::local_tempfile(fileext = ".osm") + job <- callr::r_bg(function(q, osm_file) { # update spinner while blocking method call osmdata::osmdata_xml(q, filename = osm_file, quiet = FALSE) }, args = list(q, osm_file)) @@ -110,28 +134,48 @@ osm_shapes_to_routes <- function( pb$update(0.5) # 2. Convert to SF and Extract routes - job <- callr::r_bg(function(q, osm_file) { # update spinner while blocking method call - return(osmdata::osmdata_sf(q, osm_file)) - }, args = list(q, osm_file)) + pb <- progress::progress_bar$new( # Track progress + format = sprintf("1/%d: Querying OSM for transit routes... [:bar] :percent :spin elapsed=:elapsed", total_steps), + clear = FALSE, show_after = 0 + ) + pb$update(0) + + # Convert query to XML string for overpass API + if ("opq" %in% class(q)) { # opq format + query_xml <- osmdata::opq_string(q) + } else if ("character" %in% class(q)) { # xml format + query_xml <- q + } else { + stop("Invalid query format. Must be an opq object or a valid XML string.") + } + + # Query Overpass API + job <- callr::r_bg(function(query_xml) { # update spinner while blocking method call + requireNamespace("osmdata", quietly = TRUE) + return(osmdata::osmdata_sf(query_xml)) + }, args = list(query_xml)) while (job$is_alive()) { pb$tick(0) Sys.sleep(0.1) } osm <- job$get_result() + pb$update(0.5) + # Extract geometries + osm_multilines <- osm$osm_multilines pb$update(0.75) - osm_multilines <- osm$osm_multilines + # Generate redux multiline (geometry per osm_id) osm_multilines_redux <- osm_multilines |> - select(any_of(c("osm_id", "gtfs:shape_id"))) + dplyr::select(any_of(c("osm_id", "name", "ref", "gtfs:shape_id", "geometry"))) |> + st_as_sf() + pb$update(1) + pb$terminate() } - pb$update(1) - pb$terminate() - # 3. Merge with GTFS shape_ids <- gtfs$trips |> - select(shape_id) |> + select("shape_id") |> distinct() pb <- progress::progress_bar$new( # Track progress format = sprintf("2/%d: Matching %d shapes with %s routes [:bar] :percent :spin elapsed=:elapsed", total_steps, nrow(shape_ids), nrow(osm_multilines_redux)), @@ -147,7 +191,7 @@ osm_shapes_to_routes <- function( pb$terminate() # If relation disaggregation - if (ways && is.null(osm_file)) { + if (ways && is.null(initial_osm_file)) { # 4. Processing OSM relations (already have the file!) pb <- progress::progress_bar$new( # Track progress format = sprintf("3/%d: Matching OSM routes with ways [:bar] :percent :spin elapsed=:elapsed", total_steps), @@ -156,8 +200,8 @@ osm_shapes_to_routes <- function( pb$update(0) job <- callr::r_bg(function(osm_file) { # update spinner while blocking method call - library(xml2) - library(dplyr) + requireNamespace("xml2", quietly = TRUE) + requireNamespace("dplyr", quietly = TRUE) doc <- read_xml(osm_file) relations <- xml_find_all(doc, ".//relation") @@ -184,14 +228,14 @@ osm_shapes_to_routes <- function( } relations_df <- job$get_result() ways_relations <- relations_df |> - filter(type == "way") |> - select(ref, relation_osm_id) # ref is way osm_id + filter(.data$type == "way") |> + select("ref", "relation_osm_id") # ref is way osm_id # 4.2. Disaggregate relations in ways result <- result |> sf::st_drop_geometry() |> - left_join(ways_relations |> rename(way_osm_id = ref, osm_id = relation_osm_id), by = "osm_id") |> - left_join(as_tibble(osm$osm_lines) |> select(osm_id, contains(ways_tags)), by = c("way_osm_id" = "osm_id")) + left_join(ways_relations |> rename(way_osm_id = .data$ref, osm_id = .data$relation_osm_id), by = "osm_id") |> + left_join(as_tibble(osm$osm_lines) |> select("osm_id", contains(ways_tags)), by = c("way_osm_id" = "osm_id")) geom <- osm$osm_lines$geometry names(geom) <- NULL @@ -200,14 +244,14 @@ osm_shapes_to_routes <- function( pb$update(1) pb$terminate() - } else if (ways && !is.null(ways_tags) && length(ways_tags) > 0) { + } else if (ways && !is.null(initial_osm_file) && !is.null(ways_tags) && length(ways_tags) > 0) { ways_other_tags <- osmextract::oe_get_keys(osm_ways) # Filter ways_other_tags for elements that contain any of strings in ways_tags tags_to_extract <- ways_other_tags[Reduce(`|`, lapply(ways_tags, function(t) grepl(t, ways_other_tags)))] osm_extra_tags <- osmextract::oe_read(osm_file, boundary = bbox, quiet = TRUE, extra_tags = tags_to_extract) |> st_drop_geometry() names(osm_extra_tags)[names(osm_extra_tags) != "osm_id"] <- gsub("_", ":", names(osm_extra_tags)[names(osm_extra_tags) != "osm_id"]) result <- result |> - left_join(osm_extra_tags |> select(-`other:tags`), by = c("way_osm_id" = "osm_id")) + left_join(osm_extra_tags |> select(-"other:tags"), by = c("way_osm_id" = "osm_id")) # Remove columns that only have empty values result <- result |> dplyr::select(dplyr::where(~ { @@ -220,22 +264,22 @@ osm_shapes_to_routes <- function( # 4. Log missing shapes/routes routes_shapes <- gtfs$routes |> - select(route_id, route_short_name, route_long_name) |> - right_join(gtfs$trips |> select(trip_id, route_id, shape_id), by = "route_id") |> - distinct(route_id, shape_id, .keep_all = TRUE) + select("route_id", "route_short_name", "route_long_name") |> + right_join(gtfs$trips |> select("trip_id", "route_id", "shape_id"), by = "route_id") |> + distinct(.data$route_id, .data$shape_id, .keep_all = TRUE) shapes_matched_n <- result |> - distinct(shape_id) |> + distinct(.data$shape_id) |> nrow() shapes_gtfs_n <- gtfs$shapes |> - distinct(shape_id) |> + distinct(.data$shape_id) |> nrow() routes_matched_n <- routes_shapes |> - filter(shape_id %in% result$shape_id) |> - distinct(route_id) |> + filter(.data$shape_id %in% result$shape_id) |> + distinct(.data$route_id) |> nrow() routes_gtfs_n <- gtfs$routes |> - distinct(route_id) |> + distinct(.data$route_id) |> nrow() message(sprintf( @@ -243,9 +287,9 @@ osm_shapes_to_routes <- function( shapes_matched_n, shapes_matched_n / shapes_gtfs_n * 100, shapes_gtfs_n, routes_matched_n, routes_matched_n / routes_gtfs_n * 100, routes_gtfs_n )) - routes_shapes_missing <- routes_shapes |> filter(!(shape_id %in% result$shape_id)) + routes_shapes_missing <- routes_shapes |> filter(!(.data$shape_id %in% result$shape_id)) if (nrow(routes_shapes_missing) > 0) { - row_strings <- with(routes_shapes_missing, sprintf("| %s | %s | %s | %s |", route_id, shape_id, route_short_name, route_long_name)) + row_strings <- sprintf("| %s | %s | %s | %s |", routes_shapes_missing$route_id, routes_shapes_missing$shape_id, routes_shapes_missing$route_short_name, routes_shapes_missing$route_long_name) warning(sprintf("Shapes missing (ignored in the result):\n| route_id | shape_id | route_short_name | route_long_name |\n%s", paste(row_strings, collapse = "\n"))) } diff --git a/R/rt_average_speed.R b/R/rt_average_speed.R index c151e5e4..8411b223 100644 --- a/R/rt_average_speed.R +++ b/R/rt_average_speed.R @@ -1,7 +1,7 @@ #' Estimate average speed for GTFS-RT trip updates #' #' Projects each real-time vehicle position to its corresponding trip geometry, -#' computes cumulative distance along the shape, and derives segment speed +#' computes cumulative distance along the geometry, and derives segment speed #' between consecutive updates. #' #' @param rt_collection sf data.frame with GTFS-RT updates for multiple trips. @@ -24,8 +24,8 @@ #' \eqn{t_1 \le t_2 \le \dots \le t_n}. Each observation is projected onto the #' trip geometry using \code{GTFShift::project_points_along_geometry()}, yielding #' a projected point \eqn{\hat{x}_i} and two cumulative distances: -#' \deqn{d_i = \text{distance_along_geometry}(\hat{x}_i)} -#' \deqn{d_i^{\mathrm{rev}} = \text{distance_along_geometry_reversed}(\hat{x}_i)} +#' \deqn{d_i = \text{distance\_along\_geometry}(\hat{x}_i)} +#' \deqn{d_i^{\mathrm{rev}} = \text{distance\_along\_geometry\_reversed}(\hat{x}_i)} #' #' For each pair of consecutive observations \eqn{(i-1, i)}, the elapsed time is #' computed as @@ -62,7 +62,7 @@ #' Method \code{GTFShift::multiline_to_sorted_linestring()} can be used to convert MULTILINESTRING #' geometries to LINESTRING if needed. #' -#' @returns An \code{sf} object based on \code{rt_collection}, with added columns: +#' @returns sf data.frame. Object based on \code{rt_collection}, with added columns: #' \describe{ #' \item{closest_on_shape}{Projected point on trip geometry.} #' \item{distance_to_closest_on_geometry}{Distance from each update point to its projected location on the shape (meters).} @@ -74,19 +74,53 @@ #' } #' #' @examples -#' \dontrun{ -#' rt_collection <- read.csv("rt_collection.csv") # sf object with GTFS-RT updates (trip_id, timestamp, geometry) -#' trips_geometries <- sf::st_read("osm_geometries.gpkg") # sf object with LINESTRING geometry per trip -#' speeds <- GTFShift::rt_average_speed(rt_collection, trips_geometries) -#' } +#' # Get GTFS-RT data collection +#' rt_collect_file <- system.file( +#' "extdata/samples", "gtfs_rt_sample_tcb_4_4-CS-TERM.csv", package = "GTFShift" +#' ) +#' rt_collection <- read.csv(rt_collect_file) |> +#' sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) |> dplyr::select(-speed) +#' +#' head(rt_collection |> dplyr::select(trip_id, timestamp, geometry)) +#' +#' nrow(rt_collection) +#' +#' # Get route geometry for data collected +#' osm_routes <- sf::st_read( +#' system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), +#' quiet = TRUE +#' ) |> +#' dplyr::filter(route_id %in% rt_collection$route_id) |> +#' dplyr::mutate(geom = GTFShift::multiline_to_sorted_linestring(geom, metric_crs = 3763)) +#' +#' head(osm_routes) +#' +#' # Compute average speed (aggregated at route level) based on cumulative distance along the geometry +#' speed <- GTFShift::rt_average_speed( +#' rt_collection = rt_collection, +#' trips_geometries = osm_routes, +#' rt_collection_trips_geometries_match_col = "route_id", +#' metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +#' ) +#' +#' head(speed |> +#' dplyr::filter(!is.na(speed_kmh)) |> +#' dplyr::select( +#' trip_id, timestamp, speed_kmh, +#' distance_along_geometry, distance_to_closest_on_geometry +#' ) +#' ) +#' +#' nrow(speed) #' #' @seealso \code{GTFShift::project_points_along_geometry()} #' @seealso \code{GTFShift::multiline_to_sorted_linestring()} #' #' @import sf #' @import dplyr -#' @import purrr +#' @importFrom purrr map_dfr #' @import rlang +#' @importFrom rlang .data #' #' @export rt_average_speed <- function( @@ -126,14 +160,14 @@ rt_average_speed <- function( # 1. Compute speed for each trip update rt_collection |> sf::st_transform(crs = metric_crs) |> - group_split(trip_id) |> + group_split(.data$trip_id) |> purrr::map_dfr(function(trip_df) { # If trip has less than 2 updates, ignore it if (nrow(trip_df) < 2) { warning(paste("Trip", trip_df[[rt_collection_trips_geometries_match_col]][[1]], "has less than 2 updates. Ignoring it.")) return(NULL) } - trip_df <- trip_df |> arrange(timestamp) |> st_transform(crs = metric_crs) + trip_df <- trip_df |> arrange(.data$timestamp) |> st_transform(crs = metric_crs) trip_geometry <- trips_geometries |> filter(!!sym(rt_collection_trips_geometries_match_col) == trip_df[[rt_collection_trips_geometries_match_col]][[1]]) |> st_transform(crs = metric_crs) @@ -153,19 +187,19 @@ rt_average_speed <- function( distance_to_closest_on_geometry = projected$distance_to_closest_on_geometry ) trip_df <- trip_df |> mutate( - time_since_prev_sec = timestamp - lag(timestamp), + time_since_prev_sec = .data$timestamp - lag(.data$timestamp), # When computing distances # 1. Use absolute value to avoid negative distances # 2. Consider both normal and reversed distances (to work with circular shapes) and take the minimum - distance_since_prev_meters_normal = abs(distance_along_geometry - lag(distance_along_geometry)), - distance_since_prev_meters_reversed = abs(distance_along_geometry - lag(distance_along_geometry_reversed)), - distance_since_prev_meters = pmin(distance_since_prev_meters_normal, distance_since_prev_meters_reversed, na.rm = TRUE), + distance_since_prev_meters_normal = abs(.data$distance_along_geometry - lag(.data$distance_along_geometry)), + distance_since_prev_meters_reversed = abs(.data$distance_along_geometry - lag(.data$distance_along_geometry_reversed)), + distance_since_prev_meters = pmin(.data$distance_since_prev_meters_normal, .data$distance_since_prev_meters_reversed, na.rm = TRUE), # Compute speed in km/h - speed_kmh = (distance_since_prev_meters / 1000) / (time_since_prev_sec / 3600), - distance_since_prev_meters = round(distance_since_prev_meters, 2), - speed_kmh = round(speed_kmh, 2), - distance_along_geometry = round(distance_along_geometry, 2) - ) |> select(-distance_since_prev_meters_normal, -distance_since_prev_meters_reversed) + speed_kmh = (.data$distance_since_prev_meters / 1000) / (.data$time_since_prev_sec / 3600), + distance_since_prev_meters = round(.data$distance_since_prev_meters, 2), + speed_kmh = round(.data$speed_kmh, 2), + distance_along_geometry = round(.data$distance_along_geometry, 2) + ) |> select(-"distance_since_prev_meters_normal", -"distance_since_prev_meters_reversed") # mapview(trip_df, zcol = "distance_along_geometry", layer.name = "Distance along geometry") + mapview(trip_df, zcol = "speed_kmh", layer.name = "Speed (km/h)") + mapview(trip_geometry, color = "blue", lwd = 3, layer.name = "Trip geometry") # |> filter( # !is.na(speed_kmh) & diff --git a/R/rt_collect_json.R b/R/rt_collect_json.R index 31551c7d..e4dac16c 100644 --- a/R/rt_collect_json.R +++ b/R/rt_collect_json.R @@ -4,8 +4,8 @@ #' @param gtfs_rt_url String. URL of the GTFS-RT feed in JSON format. #' @param destination_file String. File to save the downloaded GTFS-RT data. Content is appended in each iteration. #' @param header_key String (Default "header"). Key in the JSON corresponding to the feed header. Set to NA if not present. -#' @param entity_key String (Default "entity"). Key in the JSON corresponding to the feed entities. Set to NA if response is a flat list. -#' @param fields_collect Character vector. Fields to extract from each entity in the feed. +#' @param entity_key String (Default "entity"). Key in the JSON corresponding to the feed entities. Set to NA if response is a flat list. Use "." for nested keys. +#' @param fields_collect Character vector. Fields to extract from each entity in the feed. Use "." for nested keys. #' @param scrape_interval Integer (Default 60). Interval in seconds between each download. Negative to run only once. #' @param log_file String (Optional). Path to a log file to save download logs. #' @param headers Named list or character vector (Optional). Custom HTTP headers for credentials when accessing the GTFS-RT feed URL. @@ -15,43 +15,71 @@ #' #' This function will run indefinitely until manually stopped (CTRL + C). #' +#' @returns String. The location of the file where data was collected. #' #' @examples -#' \dontrun{ -#' GTFShift::rt_collect_json("https://api.example.com/gtfs-rt", "gtfs_rt_data.csv") -#' } +#' # Create file +#' destination_file <- withr::local_tempfile(fileext = ".csv") #' -#' @import jsonlite -#' @import progress +#' # Collect data +#' GTFShift::rt_collect_json( +#' gtfs_rt_url = "https://go.tmlmobilidade.pt/hub/api/v1/realtime/vehicles/positions/gtfs", +#' entity_key = "data.entity", +#' destination_file = destination_file, +#' scrape_interval = -1 # Negative to run only once +#' ) +#' +#' # Read data +#' collection <- read.csv(destination_file) +#' +#' names(collection) +#' +#' head( +#' collection |> +#' dplyr::select("vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude") +#' ) +#' +#' @importFrom jsonlite fromJSON +#' @importFrom utils write.table #' #' @export rt_collect_json <- function( - gtfs_rt_url, destination_file, - header_key="header", # Optional - entity_key="entity", - fields_collect = c("id", "vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude", "vehicle.position.speed", "vehicle.timestamp", "vehicle.current_status", "vehicle.current_stop_sequence", "vehicle.stop_id"), - scrape_interval = 60, log_file = NA, headers = NULL + gtfs_rt_url, destination_file, + header_key = "header", # Optional + entity_key = "entity", + fields_collect = c("id", "vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude", "vehicle.position.speed", "vehicle.timestamp", "vehicle.current_status", "vehicle.current_stop_sequence", "vehicle.stop_id"), + scrape_interval = 60, log_file = NA, headers = NULL ) { # Log script start - m = sprintf("[%s] Starting GTFS-RT data collection from %s", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), gtfs_rt_url) + m <- sprintf("[%s] Starting GTFS-RT data collection from %s", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), gtfs_rt_url) message(m) if (!is.na(log_file)) cat(paste(m, "\n"), file = log_file, append = TRUE) # Each scrape_interval seconds, download the GTFS-RT feed and save it to the destination folder - count = 0 + count <- 0 repeat { - count = count + 1 + count <- count + 1 timestamp <- format(Sys.time(), "%Y%m%d_%H%M%S") if (grepl("^http", gtfs_rt_url) && !is.null(headers)) { res <- httr::GET(gtfs_rt_url, httr::add_headers(.headers = headers)) httr::stop_for_status(res) - feed <- jsonlite::fromJSON(httr::content(res, as="text", encoding="UTF-8")) + feed <- jsonlite::fromJSON(httr::content(res, as = "text", encoding = "UTF-8")) } else { feed <- jsonlite::fromJSON(gtfs_rt_url) } - if (!is.na(entity_key)) { - entities <- as.data.frame(feed[[entity_key]]) + if (!is.na(entity_key) && entity_key != "") { + entity_parts <- unlist(strsplit(entity_key, "\\.")) + entities_target <- feed + for (part in entity_parts) { + if (!is.null(entities_target) && part %in% names(entities_target)) { + entities_target <- entities_target[[part]] + } else { + entities_target <- NULL + break + } + } + entities <- as.data.frame(entities_target) } else { entities <- feed } @@ -78,7 +106,7 @@ rt_collect_json <- function( } if (!is.na(header_key)) { - header = feed[[header_key]] + header <- feed[[header_key]] if ("timestamp" %in% names(header)) { feed_df$feed_timestamp <- header$timestamp } @@ -93,29 +121,34 @@ rt_collect_json <- function( sep = ",", row.names = FALSE, col.names = !file.exists(destination_file), # only write header if file is new - append = TRUE + append = file.exists(destination_file) ) - m = sprintf("[%s] Iteration %d completed", timestamp, count) + m <- sprintf("[%s] Iteration %d completed", timestamp, count) message(m) if (!is.na(log_file)) cat(paste(m, "\n"), file = log_file, append = TRUE) # Wait for scrape_interval seconds before the next download - if (scrape_interval<0) { + if (scrape_interval < 0) { break } interval_start <- Sys.time() + if (!requireNamespace("progress", quietly = TRUE)) { + stop("Package 'progress' is required for interval sleeping display. Install it with: install.packages('progress')") + } pb <- progress::progress_bar$new( # Track progress format = "Sleeping [:bar] :percent :spin elapsed=:elapsed", - clear = FALSE, show_after=0 + clear = FALSE, show_after = 0 ) pb$update(0) repeat { - elapsed_time <- as.numeric(difftime(Sys.time(), interval_start, units="secs")) - if (elapsed_time >= scrape_interval) break; - pb$update( min(elapsed_time / scrape_interval, 1) ); - Sys.sleep(0.1); + elapsed_time <- as.numeric(difftime(Sys.time(), interval_start, units = "secs")) + if (elapsed_time >= scrape_interval) break + pb$update(min(elapsed_time / scrape_interval, 1)) + Sys.sleep(0.1) } pb$update(1) } + + return(destination_file) } diff --git a/R/rt_collect_protobuf.R b/R/rt_collect_protobuf.R index 69d6ec21..85349172 100644 --- a/R/rt_collect_protobuf.R +++ b/R/rt_collect_protobuf.R @@ -13,51 +13,74 @@ #' #' This function will run indefinitely until manually stopped (CTRL + C). #' +#' @returns String. The location of the file where data was collected. #' #' @examples -#' \dontrun{ -#' GTFShift::rt_collect_protobuf("https://api.example.com/gtfs-rt-protobuf", "gtfs_rt_data.csv") -#' } +#' # Create file +#' destination_file <- withr::local_tempfile(fileext = ".csv") #' -#' @import RProtoBuf -#' @import jsonlite -#' @import progress +#' # Collect data +#' GTFShift::rt_collect_protobuf( +#' gtfs_rt_url = "https://go.tmlmobilidade.pt/hub/api/v1/realtime/vehicles/positions/gtfs.pb", +#' destination_file = destination_file, +#' scrape_interval = -1 # Negative to run only once +#' ) #' +#' # Read data +#' collection <- read.csv(destination_file) +#' +#' names(collection) +#' +#' head( +#' collection |> +#' dplyr::select("vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude") +#' ) +#' +#' @importFrom jsonlite write_json +#' @importFrom stats setNames #' @export rt_collect_protobuf <- function( - gtfs_rt_url, destination_file, - fields_collect = c("id", "vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude", "vehicle.position.speed", "vehicle.timestamp", "vehicle.current_status", "vehicle.current_stop_sequence", "vehicle.stop_id"), - scrape_interval = 60, log_file = NA, headers = NULL + gtfs_rt_url, destination_file, + fields_collect = c("id", "vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude", "vehicle.position.speed", "vehicle.timestamp", "vehicle.current_status", "vehicle.current_stop_sequence", "vehicle.stop_id"), + scrape_interval = 60, log_file = NA, headers = NULL ) { # Log script start - m = sprintf("[%s] Starting GTFS-RT data collection from %s", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), gtfs_rt_url) + m <- sprintf("[%s] Starting GTFS-RT data collection from %s", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), gtfs_rt_url) message(m) if (!is.na(log_file)) cat(paste(m, "\n"), file = log_file, append = TRUE) # Each scrape_interval seconds, download the GTFS-RT feed and save it to the destination folder - count = 0 + count <- 0 repeat { - count = count + 1 + count <- count + 1 timestamp <- format(Sys.time(), "%Y%m%d_%H%M%S") # Load protobuf + if (!requireNamespace("RProtoBuf", quietly = TRUE)) { + stop("Package 'RProtoBuf' is required for this function. Install it with: install.packages('RProtoBuf')") + } RProtoBuf::readProtoFiles((system.file("extdata", "gtfs-realtime.proto", package = "GTFShift"))) if (grepl("^http", gtfs_rt_url) && !is.null(headers)) { - temp_pb <- tempfile(fileext = ".pb") + temp_pb <- withr::local_tempfile(fileext = ".pb") res <- httr::GET(gtfs_rt_url, httr::add_headers(.headers = headers), httr::write_disk(temp_pb, overwrite = TRUE)) httr::stop_for_status(res) f <- file(temp_pb, "rb") } else { f <- file(gtfs_rt_url, "rb") } - feed <- RProtoBuf::read(`transit_realtime.FeedMessage`, f) + on.exit(close(f), add = TRUE) + feed_desc <- RProtoBuf::P("transit_realtime.FeedMessage") + feed <- RProtoBuf::read(feed_desc, f) close(f) + on.exit(NULL, add = FALSE) # Convert to R list fields <- names(feed) protobuf_to_list <- function(msg) { - if (!inherits(msg, "Message")) return(msg) + if (!inherits(msg, "Message")) { + return(msg) + } # get all fields fields <- names(msg) @@ -77,8 +100,8 @@ rt_collect_protobuf <- function( } feed_list <- protobuf_to_list(feed) - temp_json = tempfile(fileext = ".json") - write_json( + temp_json <- withr::local_tempfile(fileext = ".json") + jsonlite::write_json( feed_list, temp_json, pretty = TRUE, @@ -95,26 +118,31 @@ rt_collect_protobuf <- function( ) }) - m = sprintf("[%s] Iteration %d completed", timestamp, count) + m <- sprintf("[%s] Iteration %d completed", timestamp, count) message(m) if (!is.na(log_file)) cat(paste(m, "\n"), file = log_file, append = TRUE) # Wait for scrape_interval seconds before the next download - if (scrape_interval<0) { + if (scrape_interval < 0) { break } interval_start <- Sys.time() + if (!requireNamespace("progress", quietly = TRUE)) { + stop("Package 'progress' is required for this function. Install it with: install.packages('progress')") + } pb <- progress::progress_bar$new( # Track progress format = "Sleeping [:bar] :percent :spin elapsed=:elapsed", - clear = FALSE, show_after=0 + clear = FALSE, show_after = 0 ) pb$update(0) repeat { - elapsed_time <- as.numeric(difftime(Sys.time(), interval_start, units="secs")) - if (elapsed_time >= scrape_interval) break; - pb$update( min(elapsed_time / scrape_interval, 1) ); - Sys.sleep(0.1); + elapsed_time <- as.numeric(difftime(Sys.time(), interval_start, units = "secs")) + if (elapsed_time >= scrape_interval) break + pb$update(min(elapsed_time / scrape_interval, 1)) + Sys.sleep(0.1) } pb$update(1) } + + return(destination_file) } diff --git a/R/rt_extend_prioritization.R b/R/rt_extend_prioritisation.R similarity index 60% rename from R/rt_extend_prioritization.R rename to R/rt_extend_prioritisation.R index 5e4d2347..6c67d4b4 100644 --- a/R/rt_extend_prioritization.R +++ b/R/rt_extend_prioritisation.R @@ -1,22 +1,22 @@ -#' Extend prioritization with GTFS-RT based speed metrics +#' Extend prioritisation with GTFS-RT based speed metrics #' -#' This function extends lane segment indicators for prioritization with speed metrics produced with GTFS-RT data. +#' This function extends lane segment indicators for prioritisation with speed metrics produced with GTFS-RT data. #' -#' @param lane_prioritization sf data.frame. Result of \code{GTFShift::prioritize_lanes()} +#' @param lane_prioritisation sf data.frame. Result of \code{GTFShift::prioritise_lanes()} #' @param rt_collection sf data.frame. GTFS-RT data collection. Must include \code{speed} column. #' @param rt_current_status Character vector (Default \code{c("IN_TRANSIT_TO")}). If the \code{current_status} column is present in the \code{rt_collection} data, only points with \code{current_status} in this vector are considered. #' @param lane_buffer numeric (Default 15). Buffer distance (in meters) to create around lane segments to capture nearby GTFS-RT points. #' @param metric_crs Integer or character (Default 3857). Projected CRS used to apply lane buffer distances in meters. #' #' @details -#' Extends the \code{lane_prioritization} data with speed metrics calculated from the GTFS-RT data points that fall within a buffer around each lane segment. -#' +#' Extends the \code{lane_prioritisation} data with speed metrics calculated from the GTFS-RT data points that fall within a buffer around each lane segment. +#' #' If GTFS-RT data does not provide speed information, it can be inferred from the progression of position updates through time using \code{GTFShift::rt_average_speed()}. #' #' Refer to \code{GTFShift::rt_collect_json()} or \code{GTFShift::rt_collect_protobuf()} for details on GTFS-RT data collection. #' #' -#' @returns The \code{lane_prioritization} \code{sf} \code{data.frame}, extended with the following columns: +#' @returns sf data.frame. Extended lane prioritisation with the following columns: #' \describe{ #' \item{speed_avg}{The average speed of the vehicles on the way.} #' \item{speed_median}{The median speed of the vehicles on the way.} @@ -25,26 +25,54 @@ #' \item{speed_count}{The number of speed observations on the way.} #' } #' -#' @examples -#' \dontrun{ -#' rt_collect_file <- "gtfs_rt_data.csv" -#' GTFShift::rt_collect_json("https://api.example.com/gtfs-rt", rt_collect_file) -#' lane_prioritization <- GTFShift::prioritize_lanes(gtfs, osm_query) +#' @examplesIf nzchar(Sys.which("osmium")) +#' # Subset GTFS for one route only, for demo purposes +#' gtfs <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", +#' package = "GTFShift" +#' )) +#' gtfs <- GTFShift::filter_by_route_name(gtfs, c("4")) +#' +#' # Build query and prepare osm extract (possible to use API as alternative) +#' q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> +#' osmdata::add_osm_feature(key = "route", value = "bus") |> +#' osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +#' osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") #' -#' rt_collection <- read.csv(rt_collect_file) |> sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) -#' lane_prioritization_extended <- GTFShift::rt_extend_prioritization( -#' lane_prioritization = lane_prioritization, -#' rt_collection = rt_collection +#' # Prioritise lanes +#' lane_prioritisation <- GTFShift::prioritise_lanes( +#' gtfs, q, +#' osm_file = osm_file, +#' date = gtfs$calendar$start_date[1] #' ) -#' } #' -#' @import progress -#' @import dplyr -#' @import callr +#' # Extend with GTFS-RT data collection +#' rt_collect_file <- system.file( +#' "extdata/samples", "gtfs_rt_sample_tcb_4_4-CS-TERM.csv", +#' package = "GTFShift" +#' ) +#' rt_collection <- read.csv(rt_collect_file) |> +#' sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) +#' +#' lane_prioritisation_extended <- GTFShift::rt_extend_prioritisation( +#' lane_prioritisation = lane_prioritisation, +#' rt_collection = rt_collection, +#' metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +#' ) +#' +#' head( +#' lane_prioritisation_extended |> +#' sf::st_drop_geometry() |> +#' dplyr::filter(!is.na(speed_count)) |> +#' dplyr::select(way_osm_id, speed_avg, speed_count) +#' ) +#' +#' @importFrom callr r_bg +#' @importFrom rlang .data #' #' @export -rt_extend_prioritization <- function( - lane_prioritization, +rt_extend_prioritisation <- function( + lane_prioritisation, rt_collection, rt_current_status = c("IN_TRANSIT_TO"), lane_buffer = 15, # in meters @@ -53,9 +81,9 @@ rt_extend_prioritization <- function( metric_crs_is_default <- missing(metric_crs) # 1. Validate inputs required_cols <- c("way_osm_id") - missing_cols <- setdiff(required_cols, colnames(lane_prioritization)) + missing_cols <- setdiff(required_cols, colnames(lane_prioritisation)) if (length(missing_cols) > 0) { - stop(paste("lane_prioritization is missing required columns:", paste(missing_cols, collapse = ", "))) + stop(paste("lane_prioritisation is missing required columns:", paste(missing_cols, collapse = ", "))) } rt_attr_speed <- "speed" required_rt_cols <- c(rt_attr_speed) @@ -76,26 +104,29 @@ rt_extend_prioritization <- function( rt_collection_crs <- sf::st_crs(rt_collection) # Display feedback + if (!requireNamespace("progress", quietly = TRUE)) { + stop("Package 'progress' is required for this function. Install it with: install.packages('progress')") + } pb <- progress::progress_bar$new( # Track progress - format = "Extending prioritization with GTFS-RT metrics [:bar] :percent :spin elapsed=:elapsed", + format = "Extending prioritisation with GTFS-RT metrics [:bar] :percent :spin elapsed=:elapsed", clear = FALSE, show_after = 0 ) pb$update(0) # 2. Get only updates IN_TRANSIT if (!is.null(rt_current_status) && "current_status" %in% colnames(rt_collection)) { - rt_collection <- rt_collection %>% - dplyr::filter(current_status %in% rt_current_status) + rt_collection <- rt_collection |> + dplyr::filter(.data$current_status %in% rt_current_status) } pb$update(0.166) # 3. Get unique lane segments (to optimize spatial join) - job <- callr::r_bg(function(lane_prioritization) { # update spinner while blocking method call - library(sf) - return(lane_prioritization |> - dplyr::distinct(way_osm_id, .keep_all = TRUE) |> - dplyr::select(way_osm_id)) - }, args = list(lane_prioritization)) + job <- callr::r_bg(function(lane_prioritisation) { # update spinner while blocking method call + requireNamespace("sf", quietly = TRUE) + return(lane_prioritisation |> + dplyr::distinct(.data$way_osm_id, .keep_all = TRUE) |> + dplyr::select("way_osm_id")) + }, args = list(lane_prioritisation)) while (job$is_alive()) { pb$tick(0) Sys.sleep(0.1) @@ -121,7 +152,7 @@ rt_extend_prioritization <- function( job <- callr::r_bg(function(rt_collection, lane_buffers) { # update spinner while blocking method call return(sf::st_join( rt_collection, - lane_buffers |> dplyr::select(way_osm_id), + lane_buffers |> dplyr::select("way_osm_id"), left = FALSE, join = sf::st_within ) |> sf::st_drop_geometry()) @@ -135,8 +166,9 @@ rt_extend_prioritization <- function( # 5. Aggregate speed metrics by way_osm_id job <- callr::r_bg(function(overlap, rt_attr_speed) { # update spinner while blocking method call + requireNamespace("rlang", quietly = TRUE) return(overlap |> - dplyr::group_by(way_osm_id) |> + dplyr::group_by(.data$way_osm_id) |> dplyr::summarise( speed_avg = mean(.data[[rt_attr_speed]], na.rm = TRUE), speed_median = stats::median(.data[[rt_attr_speed]], na.rm = TRUE), @@ -153,19 +185,19 @@ rt_extend_prioritization <- function( speed_metrics <- job$get_result() pb$update(0.833) - # 6. Join speed metrics back to lane_prioritization - job <- callr::r_bg(function(lane_prioritization, speed_metrics) { # update spinner while blocking method call - library(sf) - return(lane_prioritization |> + # 6. Join speed metrics back to lane_prioritisation + job <- callr::r_bg(function(lane_prioritisation, speed_metrics) { # update spinner while blocking method call + requireNamespace("sf", quietly = TRUE) + return(lane_prioritisation |> dplyr::left_join(speed_metrics, by = "way_osm_id")) - }, args = list(lane_prioritization, speed_metrics)) + }, args = list(lane_prioritisation, speed_metrics)) while (job$is_alive()) { pb$tick(0) Sys.sleep(0.1) } - lane_prioritization_extended <- job$get_result() + lane_prioritisation_extended <- job$get_result() pb$update(1) pb$terminate() - return(lane_prioritization_extended) + return(lane_prioritisation_extended) } diff --git a/R/unify.R b/R/unify.R index 45c74d09..7e3a1373 100644 --- a/R/unify.R +++ b/R/unify.R @@ -19,20 +19,43 @@ #' #' For a detailed example, see the \code{vignette("unify")}. #' -#' @returns A tidygtfs object. +#' @returns tidygtfs. The unified GTFS feed. #' #' @examples -#' \dontrun{ -#' gtfs1 <- GTFShift::load_feed("gtfs1.zip") -#' gtfs2 <- GTFShift::load_feed("gtfs2.zip") -#' unified <- GTFShift::unify(gtfs1, gtfs2, create_transfers = TRUE) -#' } +#' # Load multiple GTFS files +#' gtfs_1 <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_tcb_sample.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs_1) +#' +#' gtfs_1$agency +#' +#' head(gtfs_1$trips) +#' +#' gtfs_2 <- GTFShift::load_feed(system.file("extdata/samples", +#' "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +#' ) +#' +#' summary(gtfs_2) +#' +#' gtfs_2$agency +#' +#' head(gtfs_2$trips) +#' +#' # Unify them +#' unified <- GTFShift::unify(gtfs_1, gtfs_2, prefix = TRUE) +#' +#' summary(unified) +#' +#' unified$agency +#' +#' head(unified$trips) #' #' @seealso \code{gtfstools::merge_gtfs()} #' @seealso \code{gtfsrouter::gtfs_transfer_table()} #' #' @importFrom gtfstools merge_gtfs -#' @importFrom gtfsrouter extract_gtfs gtfs_transfer_table #' #' @export unify <- function(..., prefix = FALSE, store_path = NA, create_transfers = FALSE, transfer_distance = 300, transfer_time = 120, transfer_street_routing = FALSE) { @@ -52,9 +75,12 @@ unify <- function(..., prefix = FALSE, store_path = NA, create_transfers = FALSE if (create_transfers) { message(sprintf("2. Generating transfers...")) + if (!requireNamespace("gtfsrouter", quietly = TRUE)) { + stop("Package 'gtfsrouter' is required to generate transfers. Install it with: install.packages('gtfsrouter')") + } + # Store in temporary file because gtfsrouter can only read files - temp_dir <- tempfile() - dir.create(temp_dir) + temp_dir <- withr::local_tempdir() gtfs_temp <- file.path(temp_dir, "gtfs.zip") tidytransit::write_gtfs(gtfs, gtfs_temp) diff --git a/README.md b/README.md index 2da7503d..74f564c4 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # GTFShift logo -[![](https://github.com/U-Shift/GTFShift/actions/workflows/pkgdown.yaml/badge.svg)](https://github.com/U-Shift/GTFShift/actions/workflows/pkgdown.yaml) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.21292010.svg)](https://doi.org/10.5281/zenodo.21292010) +[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.21292010.svg)](https://doi.org/10.5281/zenodo.21292010) [![](https://github.com/U-Shift/GTFShift/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/U-Shift/GTFShift/actions/workflows/R-CMD-check.yaml) [![codecov](https://codecov.io/gh/U-Shift/GTFShift/graph/badge.svg?token=RWVWEGGOF8)](https://codecov.io/gh/U-Shift/GTFShift) **GTFShift** encompasses a complete bundle of methods to harmonize GTFS and OSM data, enabling the integration and exploration of different layers of transit data, starting with the planned operations (GTFS), but also the infrastructure topology (OSM) and real-time information (GTFS-RT). @@ -39,10 +39,10 @@ To solve this problem, **GTFShift** provides a bundle of methods to harmonize GT > Example of GTFS original shapes (salmon) and harmonized GTFS shapes with OSM data (blue) for TCB, Barreiro, Portugal -### Bus Lane Prioritization +### Bus Lane Prioritisation **GTFShift** emerged from the necessity to understand how to get an -overview of where bus lanes should be prioritized for a given territory, +overview of where bus lanes should be prioritised for a given territory, using General Transit Feed Specification (GTFS) and OpenStreetMap (OSM) data. It provides a comprehensive bundle of methods that cover several dimensions of this @@ -57,9 +57,9 @@ Together, these can be used to identify road segments where bus lanes should be enabling for a transparent and data-driven decision-making process, suitable to different contexts and criteria. -![](man/figures/prioritization.png) +![](man/figures/prioritisation.png) -> Example of bus lane prioritization analysis for Lisbon city, considering road segments with +> Example of bus lane prioritisation analysis for Lisbon city, considering road segments with a minimum frequency of 10 buses/hour, average speed below 9.7 km/h and more than 1 lane per direction. #### Dashboard @@ -74,7 +74,7 @@ Visit it at [ushift.pt/apps/gtfshift](https://ushift.pt/apps/gtfshift). ## Related packages - [`{tidytransit}`](https://github.com/r-transit/tidytransit) -- [`{gtfstools}`](https://github.com/ipeaGIT/gtfstools/) +- [`{gtfstools}`](https://github.com/ipea/gtfstools/) - [`{gtfsrouter`}](https://github.com/UrbanAnalyst/gtfsrouter) - [`{GTFSwizard}`](https://github.com/nelsonquesado/GTFSwizard) diff --git a/_pkgdown.yml b/_pkgdown.yml index 851180e5..6e7e1340 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -12,7 +12,7 @@ navbar: components: dashboard: - text: "Bus lane prioritization dashboard" + text: "Bus lane prioritisation dashboard" href: "https://ushift.pt/apps/gtfshift" target: "_blank" @@ -22,11 +22,11 @@ reference: contents: - load_feed - query_mobilitydatabase - - title: Prioritize for bus lane implementation + - title: Prioritise for bus lane implementation contents: - - starts_with("prioritize_") - - rt_extend_prioritization - - get_prioritization_stats + - starts_with("prioritise_") + - rt_extend_prioritisation + - get_prioritisation_stats - title: Filter contents: - starts_with("filter_") @@ -57,13 +57,13 @@ articles: - title: Articles navbar: ~ contents: - - prioritize - - download - - filter - - unify - - analyse - - classify - - osm - - rt - - osm_update - - gtfs_from_osm + - articles/prioritise + - articles/download + - articles/filter + - articles/unify + - articles/analyse + - articles/classify + - articles/osm + - articles/rt + - articles/osm_update + - articles/gtfs_from_osm diff --git a/cran-comments.md b/cran-comments.md new file mode 100644 index 00000000..e8900fda --- /dev/null +++ b/cran-comments.md @@ -0,0 +1,6 @@ +## R CMD check results + +0 errors | 0 warnings | 1 note + +* Possibly misspelled words in DESCRIPTION: GTFS, OSM + - GTFS (General Transit Feed Specification) and OSM (OpenStreetMap) are standard domain-specific acronyms. diff --git a/dev/config_attachment.yaml b/dev/config_attachment.yaml new file mode 100644 index 00000000..7adfb3d4 --- /dev/null +++ b/dev/config_attachment.yaml @@ -0,0 +1,12 @@ +path.n: NAMESPACE +path.d: DESCRIPTION +dir.r: R +dir.v: vignettes +dir.t: tests +extra.suggests: ~ +pkg_ignore: ~ +document: yes +normalize: yes +inside_rmd: ~ +must.exist: yes +check_if_suggests_is_installed: yes diff --git a/dev/test_data_load.R b/dev/test_data_load.R index fa0e1394..902f98dd 100644 --- a/dev/test_data_load.R +++ b/dev/test_data_load.R @@ -54,9 +54,9 @@ stcp_data <- read.csv("releases/gtfs_rt_data/stcp.csv") summary(stcp_data) -# Extend prioritization with rt data -# lane_prioritization <- readRDS("releases/lane_prioritization/lisbon_lane_prioritization.rds") -lane_prioritization <- lanes_global +# Extend prioritisation with rt data +# lane_prioritisation <- readRDS("releases/lane_prioritisation/lisbon_lane_prioritisation.rds") +lane_prioritisation <- lanes_global rt_collection_cm <- sf::st_read("releases/gtfs_rt_data/carris_updates_more15MBusStop.csv") |> mutate( lon = str_replace(lon, "c\\(", ""), @@ -68,17 +68,17 @@ rt_collection_cm <- sf::st_read("releases/gtfs_rt_data/carris_updates_more15MBus View(rt_collection_cm |> sf::st_drop_geometry()) mapview::mapview(rt_collection_cm[sample(nrow(rt_collection_cm), 1000), ], zcol = "speed", layer.title = "RT points sample") -lane_prioritization_extended <- rt_extend_prioritization( - lane_prioritization = lane_prioritization, +lane_prioritisation_extended <- rt_extend_prioritisation( + lane_prioritisation = lane_prioritisation, rt_collection = rt_collection_cm ) -summary(lane_prioritization_extended$speed_avg) -summary(lane_prioritization_extended$speed_count) +summary(lane_prioritisation_extended$speed_avg) +summary(lane_prioritisation_extended$speed_count) -mapview::mapview(lane_prioritization_extended, zcol = "speed_avg", layer.title = "Avg speed") +mapview::mapview(lane_prioritisation_extended, zcol = "speed_avg", layer.title = "Avg speed") -lanes_extended <- lane_prioritization_extended |> filter(hour == 8) +lanes_extended <- lane_prioritisation_extended |> filter(hour == 8) map_aggregated_simplified_extended <- mapview::mapview( lanes_extended |> filter((frequency < 5 | (is.na(n_lanes) | n_lanes_direction <= 1)) & is_bus_lane), @@ -99,6 +99,6 @@ output <- "releases/web" library(mapview) mapshot( map_aggregated_simplified_extended, - file = file.path(output, "map_rt_extended_prioritization.html"), + file = file.path(output, "map_rt_extended_prioritisation.html"), selfcontained = TRUE ) diff --git a/dev/test_prioritize_lanes.R b/dev/test_prioritise_lanes.R similarity index 98% rename from dev/test_prioritize_lanes.R rename to dev/test_prioritise_lanes.R index fe31f547..a68e0e97 100644 --- a/dev/test_prioritize_lanes.R +++ b/dev/test_prioritise_lanes.R @@ -10,7 +10,7 @@ q <- opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> add_osm_feature(key = "route", value = c("bus", "tram")) |> add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) -lanes_global <- prioritize_lanes(gtfs, q) +lanes_global <- prioritise_lanes(gtfs, q) nrow(lanes_global) lanes <- lanes_global |> filter(hour == 8) @@ -45,7 +45,7 @@ mapview::mapview(lanes, zcol = "n_lanes_direction") mapview::mapview(lanes, zcol = "n_lanes_circulation_direction") mapview::mapview(lanes |> mutate(n_lanes_parking = as.character(n_lanes_parking)), zcol = "n_lanes_parking") -# Prioritization +# Prioritisation # Color pallete from https://colorhunt.co/palette/f63049d027528a244b111f35 map_needs <- mapview::mapview( lanes |> filter(frequency >= 5 & !is.na(n_lanes) & n_lanes_direction > 1 & !is_bus_lane), diff --git a/dev/tests_prepare.R b/dev/tests_prepare.R new file mode 100644 index 00000000..432d2e77 --- /dev/null +++ b/dev/tests_prepare.R @@ -0,0 +1,227 @@ +library(dplyr) + +# Sample GTFS ----------------------------------------------- + +TABLES <- c("agency", "routes", "trips", "shapes", "calendar", "calendar_dates", "stops", "stop_times") +simplify_gtfs <- function(gtfs) { + # Remove tables not in TABLES + gtfs[!names(gtfs) %in% TABLES] <- NULL + tidytransit::as_tidygtfs(gtfs) +} + +# Prepare sample GTFS with enough twists to make tests intersting :) +gtfs_tcb <- tidytransit::read_gtfs("https://backend.tcbarreiro.pt/download-gtfs") +summary(gtfs_tcb) +names(gtfs_tcb) + +# View(gtfs_tcb$stops) +# View(gtfs_tcb$stop_times) + +sample_safe <- function(x, n) { + if (length(x) == 0) { + return(c()) + } + sample(x, min(n, length(x))) +} + +# Get stops with parent_id +stops_interesting <- gtfs_tcb$stops[!is.na(gtfs_tcb$stops$parent_station), ]$stop_id +trips_with_stops_interesting <- gtfs_tcb$stop_times |> + filter(stop_id %in% stops_interesting) |> + pull(trip_id) |> + unique() |> + sample_safe(5) + +# Get stop_times with departure_time > 24:00:00 +trips_with_stop_times_interesting <- gtfs_tcb$stop_times |> + mutate(departure_time_hh = as.numeric(substr(departure_time, 1, 2))) |> + filter(departure_time_hh >= 24) |> + pull(trip_id) |> + unique() |> + sample_safe(5) + +# Get one trip per each 3 hours block +trips_per_3_hours <- c() +for (hour in seq(0, 21, by = 3)) { + trips_per_3_hours <- c( + trips_per_3_hours, + gtfs_tcb$stop_times |> + mutate(departure_time_hh = as.numeric(substr(departure_time, 1, 2))) |> + filter(departure_time_hh >= hour & departure_time_hh < hour + 3) |> + pull(trip_id) |> + unique() |> + sample_safe(1) + ) +} + +# Get week days and weekends +service_ids <- unique(gtfs_tcb$calendar$service_id) + +trips_interesting <- unique(c( + trips_with_stops_interesting, + trips_with_stop_times_interesting, + trips_per_3_hours, + # Select 5 random trips for each service_id + service_ids |> + lapply(function(sid) { + gtfs_tcb$trips |> + filter(service_id == sid) |> + pull(trip_id) |> + unique() |> + sample_safe(5) + }) |> + unlist() +)) +length(trips_interesting) + +gtfs_tcb_filtered <- tidytransit::filter_feed_by_trips(gtfs_tcb, trips_interesting) +names(gtfs_tcb_filtered) +gtfs_tcb_filtered <- simplify_gtfs(gtfs_tcb_filtered) +summary(gtfs_tcb_filtered) +names(gtfs_tcb_filtered) + +# Merge with TTSL to cover multiple modes +gtfs_ttsl <- tidytransit::read_gtfs("https://api.transtejo.pt/files/GTFS.zip") +summary(gtfs_ttsl) + +# Get only Seixal trips +trips_seixal <- gtfs_ttsl$trips |> + filter(route_id == "3_0") |> + pull(trip_id) + +gtfs_ttsl_filtered <- tidytransit::filter_feed_by_trips(gtfs_ttsl, trips_seixal) +names(gtfs_ttsl_filtered) +gtfs_ttsl_filtered <- simplify_gtfs(gtfs_ttsl_filtered) +names(gtfs_ttsl_filtered) +summary(gtfs_ttsl_filtered) + +# Remove shapes to create sample for load_feed +gtfs_ttsl_filtered_no_shapes <- gtfs_ttsl_filtered[!names(gtfs_ttsl_filtered) %in% "shapes"] +gtfs_ttsl_filtered_no_shapes <- tidytransit::as_tidygtfs(gtfs_ttsl_filtered_no_shapes) +names(gtfs_ttsl_filtered_no_shapes) +summary(gtfs_ttsl_filtered_no_shapes) +tidytransit::write_gtfs(gtfs_ttsl_filtered_no_shapes, "inst/extdata/gtfs_ttsl_sample_no_shapes.zip") + +# For each table at ttsl, make sure tcb only has the same columns (remove from either when not in both, keeping parent_station if present in either) +names(gtfs_ttsl_filtered$stops) +names(gtfs_tcb_filtered$stops) +for (table in names(gtfs_ttsl_filtered)) { + if (table %in% names(gtfs_tcb_filtered)) { + common_cols <- intersect(names(gtfs_ttsl_filtered[[table]]), names(gtfs_tcb_filtered[[table]])) + if ("parent_station" %in% names(gtfs_ttsl_filtered[[table]]) || "parent_station" %in% names(gtfs_tcb_filtered[[table]])) { + common_cols <- unique(c(common_cols, "parent_station")) + } + gtfs_ttsl_filtered[[table]] <- gtfs_ttsl_filtered[[table]][, intersect(common_cols, names(gtfs_ttsl_filtered[[table]]))] + gtfs_tcb_filtered[[table]] <- gtfs_tcb_filtered[[table]][, intersect(common_cols, names(gtfs_tcb_filtered[[table]]))] + } +} +names(gtfs_ttsl_filtered$stops) +names(gtfs_tcb_filtered$stops) + +# Merge GTFS +gtfs_tcb_filtered_simpler <- tidytransit::filter_feed_by_trips(gtfs_tcb_filtered, trips_interesting[1]) +summary(gtfs_tcb_filtered_simpler) +gtfs_merged <- unify(gtfs_tcb_filtered_simpler, gtfs_ttsl_filtered) # , prefix = TRUE) + +# Store samples to extdara +tidytransit::write_gtfs(gtfs_tcb_filtered, "inst/extdata/gtfs_tcb_sample.zip") +tidytransit::write_gtfs(gtfs_merged, "inst/extdata/gtfs_merged_sample.zip") + +# Sample OSM ----------------------------------------------- + +## Filter TCB relations directly from the PBF -------------------------------- +bash = """ +# 1. Filter ALL bus routes +osmium tags-filter portugal-latest.osm.pbf r/route=bus -o all_buses.pbf --overwrite + +# 2. Filter ONLY TCB networks from those bus routes (using exact string matching) +osmium tags-filter all_buses.pbf \ + r/network=TCB \ + r/network="Transportes Coletivos do Barreiro" \ + r/network="Transportes Colectivos do Barreiro" \ + r/operator=TCB \ + r/operator="Transportes Coletivos do Barreiro" \ + -o tcb_relations.pbf --overwrite + +# Generate the recursive members file directly from the full Portugal PBF +osmium getid -r -t -I tcb_relations.pbf portugal-latest.osm.pbf -o osmextract_tcb_network.pbf --overwrite + +# Generate gpkg to validate +ogr2ogr -f GPKG osmextract_tcb_network.gpkg osmextract_tcb_network.pbf +""" + +## Filter TCB relations layers to gpkg -------------------------------- +OSM_EXPORT_GPKG = "~/.local/share/R/osmextract/osmextract_tcb_network.gpkg" +sf::st_layers(OSM_EXPORT_GPKG) +ways = sf::st_read(OSM_EXPORT_GPKG, layer="lines") +mapview::mapview(ways) +View(ways) +sf::st_write(ways |> dplyr::select(osm_id), "inst/extdata/osm_ways_tcb.gpkg") + +routes = sf::st_read(OSM_EXPORT_GPKG, layer="multilinestrings") +routes$shape_id <- ifelse(grepl('"gtfs:shape_id"=>"', routes$other_tags), sub('.*"gtfs:shape_id"=>"([^"]+)".*', '\\1', routes$other_tags), NA_character_) +routes$route_id <- ifelse(grepl('"gtfs:route_id"=>"', routes$other_tags), sub('.*"gtfs:route_id"=>"([^"]+)".*', '\\1', routes$other_tags), NA_character_) +# route_id starts with 1_, 2_, 3_ or 4_ +routes = routes |> filter(grepl("^[1-4]_", route_id)) +mapview::mapview(routes) +View(routes |> sf::st_drop_geometry()) +sf::st_write(routes |> dplyr::select(osm_id, shape_id, route_id), "inst/extdata/samples/osm_routes_tcb.gpkg", delete_dns = TRUE) + +## Filter Lisbon highways -------------------------------- +census_aml = sf::st_read("https://github.com/U-Shift/MQAT/raw/refs/heads/main/data/census.gpkg", quiet = TRUE) +names(census_aml) +# Filter by those that have UID starting by +# 110657 (Avenidas Novas), 110654 (Alvalade) and 110655 (Areeiro) +census_aml = census_aml |> + mutate(UID = as.character(UID)) |> + filter(grepl("^(110657|110654|110655)", UID)) |> + sf::st_union() |> + sf::st_transform(4326) +mapview::mapview(census_aml) + +sf::st_write(census_aml, "~/.local/share/R/osmextract/lisbon_bbox.geojson", delete_dns = TRUE) + +""" +# Option B: Two-step process +# 1. Clip the full PBF to your GeoJSON boundary +osmium extract -p lisbon_bbox.geojson portugal-latest.osm.pbf -o lisbon_bbox_clip.pbf --overwrite + +# 2. Extract all ways tagged with 'highway' (along with their nodes) +osmium tags-filter lisbon_bbox_clip.pbf w/highway=primary,secondary,tertiary -o lisbon_highways.pbf --overwrite +""" + +## OSM for all elements inside relation 6384187 -------------------------------- +""" +# 1. Extract relation 6384187 and its member ways to build the boundary polygon +osmium getid -r -t portugal-latest.osm.pbf r6384187 -o relation_boundary.pbf --overwrite + +# 2. Convert relation boundary to GeoJSON polygon +ogr2ogr -f GeoJSON relation_boundary.geojson relation_boundary.pbf multipolygons + +# 3. Clip full PBF to the relation geometry boundary (broad extract) +osmium extract -p relation_boundary.geojson portugal-latest.osm.pbf -o relation_area_all.pbf --overwrite + +# 4. Filter to ONLY the OSM elements needed by osm_centerline_neatnet.py: +# - Ways: ALL highway=* types (pyrosm needs the full network; Python filters types later) +# - Ways/areas: building=* for exclusion mask (Step 2 in Python) +# - Ways/areas: landuse=construction|cemetery for exclusion mask +# - Ways/areas: amenity=school for exclusion mask +# - Ways/areas: leisure=pitch for exclusion mask +# Referenced nodes are included automatically by osmium tags-filter +osmium tags-filter relation_area_all.pbf \ + "w/highway" \ + "wa/building" \ + "wa/landuse=construction,cemetery" \ + "wa/amenity=school" \ + "wa/leisure=pitch" \ + -o relation_6384187_filtered.pbf --overwrite + +# 5. Merge filtered elements with the relation boundary to include r6384187 +# relation_boundary.pbf (from step 1) already contains the relation + its members +osmium merge relation_6384187_filtered.pbf relation_boundary.pbf -o relation_6384187.pbf --overwrite + +# 6. (Optional) Convert to GPKG for validation in R/GIS +ogr2ogr -f GPKG relation_6384187.gpkg relation_6384187.pbf +""" + + diff --git a/dev/web_version.R b/dev/web_version.R index 9b214ffa..eedf0a6b 100644 --- a/dev/web_version.R +++ b/dev/web_version.R @@ -93,14 +93,14 @@ for(i in 1:nrow(regions)) { } assign(sprintf("q_%s_gtfs%s", region$name, region$gtfs_day), q) - # Prioritize based on planned operation and infrastructure characteristics - prioritization = prioritize_lanes(gtfs, q, date=region$gtfs_day) - assign(sprintf("prioritization_%s_gtfs%s", region$name, region$gtfs_day), prioritization) + # Prioritise based on planned operation and infrastructure characteristics + prioritisation = prioritise_lanes(gtfs, q, date=region$gtfs_day) + assign(sprintf("prioritisation_%s_gtfs%s", region$name, region$gtfs_day), prioritisation) - write.csv(prioritization |> sf::st_drop_geometry(), sprintf("%s/prioritization_%s_gtfs%s_run%s.csv", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), row.names = FALSE) - sf::st_write(prioritization, sprintf("%s/prioritization_%s_gtfs%s_run%s.gpkg", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), append=FALSE) + write.csv(prioritisation |> sf::st_drop_geometry(), sprintf("%s/prioritisation_%s_gtfs%s_run%s.csv", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), row.names = FALSE) + sf::st_write(prioritisation, sprintf("%s/prioritisation_%s_gtfs%s_run%s.gpkg", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), append=FALSE) - # prioritization = st_read(sprintf("%s/prioritization_%s_gtfs%s_run%s.gpkg", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date()))) + # prioritisation = st_read(sprintf("%s/prioritisation_%s_gtfs%s_run%s.gpkg", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date()))) # Extend with real-time data if available if (!is.na(region$rt_collection)) { @@ -112,21 +112,21 @@ for(i in 1:nrow(regions)) { rt_collection_filtered = rt_collection[lengths(within_distance) == 0, ] - # Extend prioritization with real-time data - prioritization = rt_extend_prioritization( - lane_prioritization = prioritization, + # Extend prioritisation with real-time data + prioritisation = rt_extend_prioritisation( + lane_prioritisation = prioritisation, rt_collection = rt_collection_filtered ) } - # Replace route_id with route names, considering that prioritization$routes has multiple route_ids separated by ";" + # Replace route_id with route names, considering that prioritisation$routes has multiple route_ids separated by ";" route_names = gtfs$routes[, c("route_id", "route_short_name", "route_long_name")] - prioritization = prioritization |> + prioritisation = prioritisation |> mutate(row_n = row_number()) - prioritization_routes = prioritization |> + prioritisation_routes = prioritisation |> st_drop_geometry() |> tidyr::separate_rows(routes, sep = ";") - routes_covered = prioritization_routes |> + routes_covered = prioritisation_routes |> select(routes) |> distinct() routes_covered = routes_covered |> @@ -135,23 +135,23 @@ for(i in 1:nrow(regions)) { route_name = ifelse(!is.na(route_short_name) & route_short_name != "", route_short_name, route_long_name) ) |> select(routes, route_name) - prioritization_routes = prioritization_routes |> + prioritisation_routes = prioritisation_routes |> left_join(routes_covered, by = c("routes" = "routes")) - prioritization_routes_grouped = prioritization_routes |> + prioritisation_routes_grouped = prioritisation_routes |> group_by(row_n) |> summarise( route_names = paste(unique(route_name), collapse = ";"), .groups = "drop" ) - prioritization = prioritization |> - left_join(prioritization_routes_grouped, by = c("row_n" = "row_n")) |> + prioritisation = prioritisation |> + left_join(prioritisation_routes_grouped, by = c("row_n" = "row_n")) |> select(-row_n) # Save outputs - write.csv(prioritization |> sf::st_drop_geometry(), sprintf("%s/prioritization_%s_gtfs%s_run%s_extended.csv", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), row.names = FALSE) - sf::st_write(prioritization, sprintf("%s/prioritization_%s_gtfs%s_run%s_extended.gpkg", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), append=FALSE) - geojson_file = sprintf("%s/prioritization_%s_gtfs%s_run%s_extended.geojson", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())) - sf::st_write(prioritization, geojson_file, append=FALSE, delete_dsn = TRUE) + write.csv(prioritisation |> sf::st_drop_geometry(), sprintf("%s/prioritisation_%s_gtfs%s_run%s_extended.csv", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), row.names = FALSE) + sf::st_write(prioritisation, sprintf("%s/prioritisation_%s_gtfs%s_run%s_extended.gpkg", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())), append=FALSE) + geojson_file = sprintf("%s/prioritisation_%s_gtfs%s_run%s_extended.geojson", output_region, region$name, region$gtfs_day, gsub("-", "", Sys.Date())) + sf::st_write(prioritisation, geojson_file, append=FALSE, delete_dsn = TRUE) # Open geojson with jsonlite, to extend with technical metadata geojson_data = jsonlite::read_json(geojson_file, digits=NA) # To avoid precision loss in coordinates @@ -179,8 +179,8 @@ for(i in 1:nrow(regions)) { } census_frequency_hour = list() for(h in 0:23) { - prioritization_hour = prioritization |> filter(hour == h) - census_frequency_hour[[as.character(h)]] = dataCensus(prioritization_hour$frequency) + prioritisation_hour = prioritisation |> filter(hour == h) + census_frequency_hour[[as.character(h)]] = dataCensus(prioritisation_hour$frequency) } metadata = list( @@ -196,16 +196,16 @@ for(i in 1:nrow(regions)) { key_exact = if (!is.null(feat$key_exact)) feat$key_exact else FALSE ) }), - prioritization = list( + prioritisation = list( routes_missing = paste(gtfs$routes |> filter(!route_id %in% routes_covered$routes) |> pull(route_short_name), collapse = ";"), routes_covered = nrow(routes_covered), routes_total = nrow(gtfs$routes) ), data_census = list( - frequency = dataCensus(prioritization$frequency), + frequency = dataCensus(prioritisation$frequency), frequency_hour = census_frequency_hour, - speed_avg = dataCensus(prioritization$speed_avg), - lanes = dataCensus(prioritization$n_lanes_direction) + speed_avg = dataCensus(prioritisation$speed_avg), + lanes = dataCensus(prioritisation$n_lanes_direction) ), rt = rt_list, execution = list( @@ -234,25 +234,25 @@ for(i in 1:nrow(regions)) { # Debug library(sf) -prioritization = st_read("releases/web/lisboa/2026-02-04/prioritization_lisboa_rt_gtfs2026-02-04_run20260203_extended.geojson") -prioritization_0800 = prioritization |> filter(hour==8) -p50_frequency = quantile(prioritization_0800$frequency, 0.5, na.rm=TRUE) -p50_speed = quantile(prioritization_0800$speed_avg, 0.5, na.rm=TRUE) +prioritisation = st_read("releases/web/lisboa/2026-02-04/prioritisation_lisboa_rt_gtfs2026-02-04_run20260203_extended.geojson") +prioritisation_0800 = prioritisation |> filter(hour==8) +p50_frequency = quantile(prioritisation_0800$frequency, 0.5, na.rm=TRUE) +p50_speed = quantile(prioritisation_0800$speed_avg, 0.5, na.rm=TRUE) mapview::mapview( - prioritization_0800 |> filter(is_bus_lane & (frequency filter(is_bus_lane & (frequency filter(is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg>p50_speed), + prioritisation_0800 |> filter(is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg>p50_speed), layer.name=sprintf("Bus lane with +%d bus/h AND +1 lane/dir AND +%.2f km/h avg.speed", p50_frequency-1, p50_speed), color="#3BC1A8", homebutton=FALSE, lwd=3 ) + mapview::mapview( - prioritization_0800 |> filter(!is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg<=p50_speed), + prioritisation_0800 |> filter(!is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg<=p50_speed), layer.name=sprintf("NO bus lane with +%d bus/h AND +1 lane/dir AND %.2f km/h or - avg.speed", p50_frequency-1, p50_speed), color="#F63049", homebutton=FALSE, diff --git a/inst/WORDLIST b/inst/WORDLIST new file mode 100644 index 00000000..2ead5ca1 --- /dev/null +++ b/inst/WORDLIST @@ -0,0 +1,83 @@ +Acknowledgement +Analyse +ArcGIS +Barreiro +CERIS +CRS +CTRL +Carris +Centerline +Coletivos +DOI +EPSG +Fertagus +GTFS +GeoPackage +HCM +Instituto +JSON +LINESTRING +Lisboa +MULTILINESTRING +Nager +OSM +OpenStreetMap +OpenStreetMaps +OsmApi +Overline +PBF +Pires +Prioritisation +Prioritise +Prioritised +Relvas +TCB +Transportes +Técnico +WGS +analyse +analysing +bbox +catalogues +centerlines +changeset +changesets +codecov +dev +disaggregated +github +gtfs +gtfshift +https +inlining +io +linestrings +macOS +mapview +misassociations +mobilitydatabase +multimodality +neatnet +oe +opq +osm +osmapi +osmdata +osmextract +overline +pbf +pre +prioritisation +prioritise +prioritised +prioritising +roadmap +sfc +summarise +th +tidygtfs +tidytransit +unvisited +uri +uscuni +ushift diff --git a/inst/extdata/samples/gtfs_merged_sample.zip b/inst/extdata/samples/gtfs_merged_sample.zip new file mode 100644 index 00000000..fca2652a Binary files /dev/null and b/inst/extdata/samples/gtfs_merged_sample.zip differ diff --git a/inst/extdata/samples/gtfs_rt_sample_tcb_4_4-CS-TERM.csv b/inst/extdata/samples/gtfs_rt_sample_tcb_4_4-CS-TERM.csv new file mode 100644 index 00000000..92445802 --- /dev/null +++ b/inst/extdata/samples/gtfs_rt_sample_tcb_4_4-CS-TERM.csv @@ -0,0 +1,11 @@ +"","trip_id","route_id","timestamp","latitude","longitude","speed" +"1","20260515_DUPE_4-CS-TERM_0_DUPE_18_0650","4_4-CS-TERM",1778825942,38.6428,-9.04843,0.08 +"2","20260514_DUPE_4-CS-TERM_0_DUPE_18_0640","4_4-CS-TERM",1778738341,38.65217,-9.07846,14.05 +"3","20260515_DUPE_4-CS-TERM_0_DUPE_18_0650","4_4-CS-TERM",1778823962,38.63645,-9.03222,0.16 +"4","20260514_DUPE_4-CS-TERM_0_DUPE_18_0640","4_4-CS-TERM",1778737742,38.64186,-9.05829,2.42 +"5","20260515_DUPE_4-CS-TERM_0_DUPE_18_0810","4_4-CS-TERM",1778832003,38.65209,-9.07844,5.16 +"6","20260515_DUPE_4-CS-TERM_0_DUPE_18_0650","4_4-CS-TERM",1778827442,38.63614,-9.0315,5.33 +"7","20260514_DUPE_4-CS-TERM_0_DUPE_18_0640","4_4-CS-TERM",1778738762,38.64169,-9.04844,4.55 +"8","20260514_DUPE_4-CS-TERM_0_DUPE_18_0640","4_4-CS-TERM",1778738882,38.63273,-9.03277,4.72 +"9","20260515_DUPE_4-CS-TERM_0_DUPE_18_0650","4_4-CS-TERM",1778825403,38.63506,-9.03264,1.3 +"10","20260515_DUPE_4-CS-TERM_0_DUPE_18_0650","4_4-CS-TERM",1778824742,38.64147,-9.05769,11.57 diff --git a/inst/extdata/samples/gtfs_tcb_sample.zip b/inst/extdata/samples/gtfs_tcb_sample.zip new file mode 100644 index 00000000..9462aa3f Binary files /dev/null and b/inst/extdata/samples/gtfs_tcb_sample.zip differ diff --git a/inst/extdata/samples/gtfs_ttsl_sample_no_shapes.zip b/inst/extdata/samples/gtfs_ttsl_sample_no_shapes.zip new file mode 100644 index 00000000..e0ef187d Binary files /dev/null and b/inst/extdata/samples/gtfs_ttsl_sample_no_shapes.zip differ diff --git a/inst/extdata/samples/osm_routes_tcb.gpkg b/inst/extdata/samples/osm_routes_tcb.gpkg new file mode 100644 index 00000000..105ab9b7 Binary files /dev/null and b/inst/extdata/samples/osm_routes_tcb.gpkg differ diff --git a/inst/extdata/samples/osm_ways_tcb.gpkg b/inst/extdata/samples/osm_ways_tcb.gpkg new file mode 100644 index 00000000..5fc3ba03 Binary files /dev/null and b/inst/extdata/samples/osm_ways_tcb.gpkg differ diff --git a/inst/extdata/samples/osmextract_lisbon_highways_sample.pbf b/inst/extdata/samples/osmextract_lisbon_highways_sample.pbf new file mode 100644 index 00000000..9148b4e7 Binary files /dev/null and b/inst/extdata/samples/osmextract_lisbon_highways_sample.pbf differ diff --git a/inst/extdata/samples/osmextract_tcb_network.pbf b/inst/extdata/samples/osmextract_tcb_network.pbf new file mode 100644 index 00000000..4483158a Binary files /dev/null and b/inst/extdata/samples/osmextract_tcb_network.pbf differ diff --git a/inst/extdata/samples/relation_6384187.pbf b/inst/extdata/samples/relation_6384187.pbf new file mode 100644 index 00000000..5a7231d6 Binary files /dev/null and b/inst/extdata/samples/relation_6384187.pbf differ diff --git a/inst/python/osm_centerline_neatnet.py b/inst/python/osm_centerline_neatnet.py index cbe80903..cff1b285 100644 --- a/inst/python/osm_centerline_neatnet.py +++ b/inst/python/osm_centerline_neatnet.py @@ -31,28 +31,53 @@ def filter_ground_level(gdf): return gdf -def get_centerline(bbox, study_area, use_buildings, output_path): - # Code adapted from https://uscuni.org/neatnet/intro.html by https://github.com/miguelpires01 - - # -------------------------------------------------------------------------- - # 1 Retrieving "highway" network (and cleaning for processing) - ## 1.1 Defining custom filter for specific "highway" features - cf = ( - '["highway"~"motorway|trunk|primary|' - "secondary|tertiary|residential|" - 'unclassified|living_street"]' - ) - cf = cf + '["area"!~"yes"]' # Exclude areas - ## 1.2 Calling OSM for the network data - network = (ox.graph_from_bbox if bbox else ox.graph_from_place)( - bbox if bbox else study_area, - network_type="all", - custom_filter=cf, - retain_all=False, - ) +def get_centerline(bbox, study_area, use_buildings, output_path, osm_file=None): + # Code adapted from https://uscuni.org/neatnet/intro.html by https://github.com/miguelrelvaspires + + if osm_file is not None: + # pyrefly: ignore [missing-import] + import pyrosm + + # Initialize pyrosm with local PBF file + osm = pyrosm.OSM(osm_file, bounding_box=bbox if bbox else None) + + # -------------------------------------------------------------------------- + # 1 Retrieving "highway" network + network_gdf = osm.get_network(network_type="all") + + if network_gdf is not None and not network_gdf.empty: + highway_types = [ + "motorway", + "trunk", + "primary", + "secondary", + "tertiary", + "residential", + "unclassified", + "living_street", + ] + if "highway" in network_gdf.columns: + network_gdf = network_gdf[network_gdf["highway"].isin(highway_types)] + else: + # -------------------------------------------------------------------------- + # 1 Retrieving "highway" network (and cleaning for processing) + ## 1.1 Defining custom filter for specific "highway" features + cf = ( + '["highway"~"motorway|trunk|primary|' + "secondary|tertiary|residential|" + 'unclassified|living_street"]' + ) + cf = cf + '["area"!~"yes"]' # Exclude areas + ## 1.2 Calling OSM for the network data + network = (ox.graph_from_bbox if bbox else ox.graph_from_place)( + bbox if bbox else study_area, + network_type="all", + custom_filter=cf, + retain_all=False, + ) - ## 1.3 Converting the network to GeoDataFrame (edges only) - network_gdf = ox.graph_to_gdfs(network, nodes=False, edges=True) + ## 1.3 Converting the network to GeoDataFrame (edges only) + network_gdf = ox.graph_to_gdfs(network, nodes=False, edges=True) ## 1.4 Drop None geometries (if any) network_gdf = network_gdf[network_gdf.geometry.notnull()] @@ -78,10 +103,25 @@ def get_centerline(bbox, study_area, use_buildings, output_path): # -------------------------------------------------------------------------- # 2 Creating "exclusion_mask" with OSM building footprints if use_buildings: - ## 2.1 Retrieving buildings - buildings = safe_features(bbox, study_area, {"building": True}) - - if buildings is not None: + if osm_file is not None: + buildings = osm.get_buildings() + construction = osm.get_landuse(custom_filter={"landuse": ["construction"]}) + schools = osm.get_pois(custom_filter={"amenity": ["school"]}) + pitches = osm.get_pois(custom_filter={"leisure": ["pitch"]}) + cemeteries = osm.get_landuse(custom_filter={"landuse": ["cemetery"]}) + else: + ## 2.1 Retrieving buildings + buildings = safe_features(bbox, study_area, {"building": True}) + ## 2.2 Retrieving construction areas + construction = safe_features(bbox, study_area, {"landuse": "construction"}) + ## 2.3 Retrieving schools + schools = safe_features(bbox, study_area, {"amenity": "school"}) + ## 2.4 Retrieving pitches + pitches = safe_features(bbox, study_area, {"leisure": "pitch"}) + ## 2.5 Retrieving cemeteries + cemeteries = safe_features(bbox, study_area, {"landuse": "cemetery"}) + + if buildings is not None and not buildings.empty: # Apply filters only if the columns exist if "building" in buildings.columns: buildings = buildings[buildings["building"] != "roof"] @@ -115,46 +155,54 @@ def get_centerline(bbox, study_area, use_buildings, output_path): buildings = filter_ground_level(buildings) - ## 2.2 Retrieving construction areas - construction = safe_features(bbox, study_area, {"landuse": "construction"}) - construction = filter_ground_level(construction) - ## 2.3 Retrieving schools - schools = safe_features(bbox, study_area, {"amenity": "school"}) - schools = filter_ground_level(schools) - ## 2.4 Retrieving pitches - pitches = safe_features(bbox, study_area, {"leisure": "pitch"}) - pitches = filter_ground_level(pitches) - ## 2.5 Retrieving cemeteries - cemeteries = safe_features(bbox, study_area, {"landuse": "cemetery"}) - cemeteries = filter_ground_level(cemeteries) + if construction is not None and not construction.empty: + construction = filter_ground_level(construction) + if schools is not None and not schools.empty: + schools = filter_ground_level(schools) + if pitches is not None and not pitches.empty: + pitches = filter_ground_level(pitches) + if cemeteries is not None and not cemeteries.empty: + cemeteries = filter_ground_level(cemeteries) + ## 2.6 Reprojecting all features to EPSG:3857 for gdf in [buildings, construction, schools, pitches, cemeteries]: - if gdf is not None: + if gdf is not None and not gdf.empty: gdf.to_crs(network_gdf_3857.crs, inplace=True) + ## 2.7 Combining all "exclusion_mask" geometries - all_exclusions = pd.concat( - [ - gdf[["geometry"]] - for gdf in [buildings, construction, schools, pitches, cemeteries] - if gdf is not None - ], - ignore_index=True, - ) + valid_exclusions = [ + gdf[["geometry"]] + for gdf in [buildings, construction, schools, pitches, cemeteries] + if gdf is not None and not gdf.empty + ] + if valid_exclusions: + all_exclusions = pd.concat(valid_exclusions, ignore_index=True) + else: + all_exclusions = pd.DataFrame() + + ## 2.8 Dissolving to a single geometry mask - exclusion_mask = gpd.GeoSeries( - unary_union(all_exclusions.geometry), crs=network_gdf_3857.crs - ) + if not all_exclusions.empty: + exclusion_mask = gpd.GeoSeries( + unary_union(all_exclusions.geometry), crs=network_gdf_3857.crs + ) + else: + exclusion_mask = None + else: + exclusion_mask = None # -------------------------------------------------------------------------- # 3 Deriving the street centerlines with "neatnet" street_lines = neatnet.neatify( network_gdf_3857, - exclusion_mask=exclusion_mask.geometry if use_buildings else None, + exclusion_mask=exclusion_mask if (use_buildings and exclusion_mask is not None) else None, ) + # -------------------------------------------------------------------------- # 4 Reprojecting layers to EPSG:4326 and storing to output path provided street_lines_4326 = street_lines.to_crs(epsg=4326) street_lines_4326.to_file(output_path, layer="street_lines", driver="GPKG") - + return street_lines_4326 + diff --git a/man/calendar_nextBusinessWednesday.Rd b/man/calendar_nextBusinessWednesday.Rd index ff03662f..6a737663 100644 --- a/man/calendar_nextBusinessWednesday.Rd +++ b/man/calendar_nextBusinessWednesday.Rd @@ -12,7 +12,7 @@ calendar_nextBusinessWednesday(start_date = Sys.Date(), country_code = "PT") \item{country_code}{String (Default PT). Country code in the format \code{ISO 3166-1 alpha-2}. When provided, public holidays are considered.} } \value{ -Date +Date. The next business Wednesday date. } \description{ Get next business Wednesday @@ -22,8 +22,10 @@ Find the next Wednesday that is not a holiday. When country is given, public hol using \href{https://date.nager.at/Api}{Nager.Date} API. } \examples{ -\dontrun{ -next_wednesday = GTFShift::calendar_nextBusinessWednesday(country_code="PT") -} +# Example of Portuguese holiday (10/06/2026) ignored +GTFShift::calendar_nextBusinessWednesday(start_date = "2026-06-09", country_code="PT") + +# Example of Hong Kong holiday (01/07/2026) ignored +GTFShift::calendar_nextBusinessWednesday(start_date = "2026-06-30", country_code="HK") } diff --git a/man/classify_frequency_los.Rd b/man/classify_frequency_los.Rd index c197cedc..6d32b8df 100644 --- a/man/classify_frequency_los.Rd +++ b/man/classify_frequency_los.Rd @@ -20,12 +20,27 @@ Classify bus frequency level of service based on HCM \details{ Classifies bus frequency level of service (LOS) based on the Highway Capacity Manual (HCM) 2000 guidelines on "Service Frequency LOS for Urban Scheduled Transit Service" (Exhibit 27-1). + +Refer to \code{vignette("classify")} for more details on this classification. } \examples{ -\dontrun{ -gtfs = GTFShift::load_feed("gtfs.zip") -frequency_analysis = GTFShift::get_route_frequency_hourly(gtfs) +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) + +# Get route frequency +frequency_analysis <- GTFShift::get_route_frequency_hourly( + gtfs, + date = gtfs$calendar$start_date[1] +) + +# Compute LOS frequency_los = GTFShift::classify_frequency_los(frequency_analysis) -} + +frequency_los |> + sf::st_drop_geometry() |> + dplyr::select(route_id, frequency_los) } diff --git a/man/create_calendar.Rd b/man/create_calendar.Rd index 0bd0e684..4163d729 100644 --- a/man/create_calendar.Rd +++ b/man/create_calendar.Rd @@ -10,7 +10,7 @@ create_calendar(gtfs) \item{gtfs}{tidygtfs. GTFS feed.} } \value{ -A data.frame for calendar.txt. +data.frame. Table for calendar.txt. } \description{ Create calendar.txt from calendar_dates.txt @@ -26,9 +26,14 @@ minimum and maximum dates and setting each week day to true if it has any date t might not be 100% accurate, as it captures the whole time span and exceptions in the week days along it are ignored. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -gtfs$calendar <- GTFShift::create_calendar(gtfs) -} +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +) + +head(gtfs$calendar_dates |> dplyr::filter(exception_type == 1)) + +gtfs_calendar <- GTFShift::create_calendar(gtfs) + +gtfs_calendar } diff --git a/man/create_shapes_from_sf.Rd b/man/create_shapes_from_sf.Rd index 2aec21d8..beb34c9e 100644 --- a/man/create_shapes_from_sf.Rd +++ b/man/create_shapes_from_sf.Rd @@ -22,7 +22,7 @@ create_shapes_from_sf( \code{shape_dist_traveled} for each generated shape.} } \value{ -A \code{data.table} representing a GTFS shapes table. Includes +data.frame. A GTFS shapes table. Includes \code{shape_dist_traveled} if \code{shape_dist_traveled = TRUE}. } \description{ @@ -35,7 +35,7 @@ It first converts any MULTILINESTRING geometries to LINESTRING geometries using \code{multiline_to_sorted_linestring}, using a point guide per shape: all ordered stops when the selected trip is circular (first and last \code{stop_id} are equal), or the first two stops otherwise. -Then, it converts the LINESTRING geometries to a data.table representing a GTFS shapes table using +Then, it converts the LINESTRING geometries to a data.frame representing a GTFS shapes table using \code{gtfstools::convert_sf_to_shapes}. Coordinates are 4326 (WGS 84) by default, following GTFS specifications. @@ -46,16 +46,27 @@ distance along each shape for all generated points and appends this as \code{metric_crs}, using \code{GTFShift::project_points_along_geometry()}. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -q <- opq("Lisbon") |> - add_osm_feature(key = "route", value = c("bus", "tram")) |> - add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) +# Load sample GTFS +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) -shapes_sf <- GTFShift::osm_shapes_to_routes(gtfs, q) +# Load TCB OSM routes sample linestring +osm_routes = sf::st_read( + system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), + quiet = TRUE +) |> dplyr::filter(shape_id \%in\% gtfs$shapes$shape_id) |> dplyr::sample_n(1) -gtfs$shapes <- GTFShift::create_shapes_from_sf(shapes_sf, gtfs) -} +head(osm_routes) + +# Create shapes.txt for geometries +shapes_txt <- GTFShift::create_shapes_from_sf( + osm_routes, gtfs, + metric_crs = 3763, # Make sure to addapt to the projection that better suits your location + shape_dist_traveled = TRUE +) + +head(shapes_txt) } \seealso{ diff --git a/man/create_shapes_from_stops.Rd b/man/create_shapes_from_stops.Rd index 3a26ccf9..4127e15a 100644 --- a/man/create_shapes_from_stops.Rd +++ b/man/create_shapes_from_stops.Rd @@ -10,7 +10,7 @@ create_shapes_from_stops(gtfs) \item{gtfs}{tidygtfs. GTFS feed.} } \value{ -The gtfs feed with the shapes table defined and the trips table updated with the matching shape_id. +tidygtfs. The GTFS feed with the shapes table defined and the trips table updated with the matching shape_id. } \description{ Build shapes from GTFS stops data @@ -21,9 +21,24 @@ The resulting shapes are a simplified version of the original ones, as they do n This can be useful for some applications that do not require high precision in the shapes, and can be used as a fallback when the original feed does not include shapes.txt file. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -gtfs$shapes <- GTFShift::create_shapes_from_stops(gtfs) -} +# Load GTFS without shapes +gtfs <- tidytransit::read_gtfs( + system.file("extdata/samples", "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +) + +summary(gtfs) + +# Create shapes from GTFS stops data +gtfs_with_shapes <- GTFShift::create_shapes_from_stops(gtfs) + +head(gtfs_with_shapes$shapes) + +head( + gtfs_with_shapes$trips |> + dplyr::select(trip_id, shape_id) |> + dplyr::distinct(shape_id, .keep_all = TRUE) +) + +summary(gtfs_with_shapes) } diff --git a/man/figures/prioritization.png b/man/figures/prioritisation.png similarity index 100% rename from man/figures/prioritization.png rename to man/figures/prioritisation.png diff --git a/man/filter_by_agency.Rd b/man/filter_by_agency.Rd index dbafb965..c9e23dbf 100644 --- a/man/filter_by_agency.Rd +++ b/man/filter_by_agency.Rd @@ -14,7 +14,7 @@ filter_by_agency(gtfs, id = NA, name = NA) \item{name}{String (Optional when id). Name of the agency.} } \value{ -A tidygtfs object with the filtered feed. +tidygtfs. The filtered GTFS feed. } \description{ Filter GTFS feed by agency @@ -23,10 +23,23 @@ Filter GTFS feed by agency Allows to filter a GTFS feed for the agency, using the id, name or both. Returns empty feed it none provided. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -gtfs_filtered_by_id <- GTFShift::filter_by_agency(gtfs, agency_id=2) -gtfs_filtered_by_name <- GTFShift::filter_by_agency(gtfs, agency_name="City bus company") -} +# Load sample feed with multiple agencies +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_merged_sample.zip", package = "GTFShift") +) + +summary(gtfs) + + +# Filter by id +gtfs_id_8 = gtfs |> GTFShift::filter_by_agency(id = "8") + +summary(gtfs_id_8) + + +# Filter by name +gtfs_ttsl <- gtfs |> GTFShift::filter_by_agency(name = "TTSL - Transtejo Soflusa") + +summary(gtfs_ttsl) } diff --git a/man/filter_by_modes.Rd b/man/filter_by_modes.Rd index a1db369b..a9a35209 100644 --- a/man/filter_by_modes.Rd +++ b/man/filter_by_modes.Rd @@ -12,7 +12,7 @@ filter_by_modes(gtfs, modes = list()) \item{modes}{Integer[]. A list with the ids of modes to consider.} } \value{ -A tidygtfs object with the filtered feed. +tidygtfs. The filtered GTFS feed. } \description{ Filter GTFS feed by mode @@ -23,9 +23,21 @@ Refer to \code{routes.txt} \code{route_type} parameter on \href{https://gtfs.org/documentation/schedule/reference/#routestxt}{GTFS documentation} for more details. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -gtfs_filtered <- GTFShift::filter_by_modes(gtfs, list(0,1)) -} +# Load sample feed with multiple modes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_merged_sample.zip", package = "GTFShift") +) + +gtfs$routes |> dplyr::select(route_id, route_type) + +summary(gtfs) + + +# Filter by bus mode (ferry agency should be excluded) +gtfs_bus <- gtfs |> GTFShift::filter_by_modes(modes = c(3)) + +gtfs_bus$routes |> dplyr::select(route_id, route_type) + +summary(gtfs_bus) } diff --git a/man/filter_by_route_name.Rd b/man/filter_by_route_name.Rd index 43063ffc..79fa1d80 100644 --- a/man/filter_by_route_name.Rd +++ b/man/filter_by_route_name.Rd @@ -16,7 +16,7 @@ filter_by_route_name(gtfs, values, short_name = TRUE, exact_match = TRUE) \item{exact_match}{Boolean. If TRUE, route name is queried for an exact match, otherwise, partial match is considered.} } \value{ -A tidygtfs object with the filtered feed. +tidygtfs. The filtered GTFS feed. } \description{ Filter GTFS feed by route name @@ -27,9 +27,17 @@ letters, words or combinations of both. This method allows to filter the feed for the route short or long name, with a partial or exact match. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -gtfs_filtered <- GTFShift::filter_by_route_name(gtfs, list("Blue line", "Red line")) -} +# Load GTFS +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) + +summary(gtfs) + + +# Filter by route +gtfs_route <- GTFShift::filter_by_route_name(gtfs, c("4")) + +summary(gtfs_route) } diff --git a/man/get_network_extension.Rd b/man/get_network_extension.Rd index 6e45bedb..700b2b7f 100644 --- a/man/get_network_extension.Rd +++ b/man/get_network_extension.Rd @@ -17,6 +17,8 @@ get_network_extension( \arguments{ \item{gtfs}{tidygtfs. GTFS feed.} +\item{route_identifier}{String. (Default \code{"route_id"}). routes.txt attribute that identifies routes. Accepted values: route_id, route_short_name, route_long_name.} + \item{direction_wise}{Boolean (Default \code{TRUE}). If TRUE, extension considers sum of both directions. Otherwise, only one direction is considered.} \item{unified}{Boolean (Default \code{FALSE}). If TRUE, overlapping route segments are only counted once in the total extension.} @@ -26,11 +28,9 @@ get_network_extension( \item{use_osm_routes}{osmdata::opq (Default NA). If overpass query for transit network is defined, analysis is performed considering OSM route geometry, using \code{GTFShift::osm_shapes_to_routes}.} \item{metric_crs}{Integer or character (Default 3857). Projected CRS used to compute route lengths in meters.} - -\item{route_identifier.}{String. (Default \code{"route_id"}). routes.txt attribute that identifies routes. Accepted values: route_id, route_short_name, route_long_name.} } \value{ -The routes extension, in meters. +Numeric. The routes extension, in meters. } \description{ Get total extension of GTFS feed routes @@ -41,12 +41,20 @@ This method calculates the sum of the GTFS feed routes length, considering, for For a detailed example, see the \code{vignette("analyse")}. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -route_extension <- GTFShift::get_network_extension(gtfs) -} +# Load GTFS +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", + package = "GTFShift" +)) + +# Get route extension +GTFShift::get_network_extension( + gtfs, + metric_crs = 3763, # Make sure to addapt to the projection that better suits your location + date = gtfs$calendar$start_date[1] +) } \seealso{ -[GTFShift::get_route_frequency_hourly()] +\code{GTFShift::get_route_frequency_hourly()} } diff --git a/man/get_prioritisation_stats.Rd b/man/get_prioritisation_stats.Rd new file mode 100644 index 00000000..c164a0a6 --- /dev/null +++ b/man/get_prioritisation_stats.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_prioritisation_stats.R +\name{get_prioritisation_stats} +\alias{get_prioritisation_stats} +\title{Get prioritisation stats} +\usage{ +get_prioritisation_stats( + lane_prioritisation, + weight = c("length", "frequency"), + metric_crs = 3857 +) +} +\arguments{ +\item{lane_prioritisation}{sf data.frame. Lane prioritisation.} + +\item{weight}{Character. Weight to use for weighted mean. Accepted values: "length", "frequency".} + +\item{metric_crs}{Integer or character (Default 3857). Projected CRS used to compute lengths in meters.} +} +\value{ +List. Statistics about lane prioritisation, with the following attributes: +\describe{ + \item{extension}{Total length of the prioritised network, in meters.} + \item{extension_bus_lane}{Total length of the bus lane segments, in meters.} + \item{speed_avg}{Average speed of the prioritised network, in km/h.} + \item{speed_min}{Minimum speed of the prioritised network, in km/h.} + \item{speed_max}{Maximum speed of the prioritised network, in km/h.} + \item{n_lanes_circulation_avg}{Average number of lanes in the prioritised network.} + \item{n_lanes_circulation_min}{Minimum number of lanes in the prioritised network.} + \item{n_lanes_circulation_max}{Maximum number of lanes in the prioritised network.} +} +} +\description{ +Get statistics about lane prioritisation +} +\examples{ +\dontshow{if (nzchar(Sys.which("osmium"))) withAutoprint(\{ # examplesIf} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("4")) + +# Build query and prepare osm extract (possible to use API as alternative) +q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> + osmdata::add_osm_feature(key = "route", value = "bus") |> + osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") + +# Prioritise lanes +lane_prioritisation <- GTFShift::prioritise_lanes( + gtfs, q, + osm_file = osm_file, + date = gtfs$calendar$start_date[1] +) + +# Get statistics for prioritisation +stats <- GTFShift::get_prioritisation_stats(lane_prioritisation, metric_crs = 3763) + +data.frame(metric = names(stats), value = unlist(stats, use.names = FALSE)) +\dontshow{\}) # examplesIf} +} diff --git a/man/get_prioritization_stats.Rd b/man/get_prioritization_stats.Rd deleted file mode 100644 index 64b81ed7..00000000 --- a/man/get_prioritization_stats.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_prioritization_stats.R -\name{get_prioritization_stats} -\alias{get_prioritization_stats} -\title{Get prioritization stats} -\usage{ -get_prioritization_stats( - lane_prioritization, - weight = c("length", "frequency"), - metric_crs = 3857 -) -} -\arguments{ -\item{lane_prioritization}{sf data.frame. Lane prioritization.} - -\item{weight}{Character. Weight to use for weighted mean. Accepted values: "length", "frequency".} - -\item{metric_crs}{Integer or character (Default 3857). Projected CRS used to compute lengths in meters.} -} -\value{ -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_circulation_avg}{Average number of lanes in the prioritized network.} - \item{n_lanes_circulation_min}{Minimum number of lanes in the prioritized network.} - \item{n_lanes_circulation_max}{Maximum number of lanes in the prioritized network.} -} -} -\description{ -Get statistics about lane prioritization -} -\examples{ -\dontrun{ -lane_prioritization <- GTFShift::prioritize_lanes(gtfs, q) -stats <- GTFShift::get_prioritization_stats(lane_prioritization) -} - -} diff --git a/man/get_route_frequency_hourly.Rd b/man/get_route_frequency_hourly.Rd index c2adb7da..3f821eeb 100644 --- a/man/get_route_frequency_hourly.Rd +++ b/man/get_route_frequency_hourly.Rd @@ -21,7 +21,7 @@ get_route_frequency_hourly( \item{overline}{Boolean (Default FALSE). If TRUE, routes are aggregated using \code{stplanr::overline2()}, overlapping lines and converting them into a single route network.} } \value{ -An \code{sf} \code{data.frame} object with the following columns (the first three are only present if \code{overline=FALSE}): +sf data.frame. Hourly route frequencies, with the following columns (the first three are only present if \code{overline=FALSE}): \describe{ \item{route_id}{The \code{route_id} attribute from \code{routes.txt} file.} \item{route_short_name}{The \code{route_short_name} attribute from \code{routes.txt} file.} @@ -49,13 +49,22 @@ By relying on a common road network, such as OSM, it is possible to overcome thi For a detailed example, see the \code{vignette("analyse")}. -Adapted from \url{https://github.com/Bondify/GTFS_in_R/}. +Adapted from \href{https://web.archive.org/web/20201223060409/https://github.com/Bondify/GTFS_in_R/}{github.com/Bondify/GTFS_in_R}. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -frequency_analysis <- GTFShift::get_route_frequency_hourly(gtfs) -} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) + +# Get frequency +frequency_analysis <- GTFShift::get_route_frequency_hourly( + gtfs, + date = gtfs$calendar$start_date[1] +) + +head(frequency_analysis |> sf::st_drop_geometry()) } \seealso{ diff --git a/man/get_stop_frequency_hourly.Rd b/man/get_stop_frequency_hourly.Rd index 710df2eb..cf1a22b9 100644 --- a/man/get_stop_frequency_hourly.Rd +++ b/man/get_stop_frequency_hourly.Rd @@ -15,7 +15,7 @@ get_stop_frequency_hourly( \item{date}{Date (Default \code{GTFShift::calendar_nextBusinessWednesday()}). Reference date to consider when analyzing the GTFS file.} } \value{ -An \code{sf} \code{data.frame} object with the following columns: +sf data.frame. Hourly stop frequencies, with the following columns: \describe{ \item{stop_id}{The \code{stop_id} attribute from \code{stops.txt} file.} \item{hour}{The hour for which the frequency applies (24 hour format).} @@ -31,10 +31,19 @@ This method analyses the GTFS feed for a representative day, generating for each For a detailed example, see the \code{vignette("analyse")}. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") -frequency_analysis <- GTFShift::get_stop_frequency_hourly(gtfs) -} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) + +# Get frequency +frequency_analysis <- GTFShift::get_stop_frequency_hourly( + gtfs, + date = gtfs$calendar$start_date[1] +) + +head(frequency_analysis) } \seealso{ diff --git a/man/get_way_frequency_hourly.Rd b/man/get_way_frequency_hourly.Rd index 5855763f..c182fb56 100644 --- a/man/get_way_frequency_hourly.Rd +++ b/man/get_way_frequency_hourly.Rd @@ -24,7 +24,7 @@ get_way_frequency_hourly( \item{osm_file}{character (Optional). Location of OSM extract file with \code{osm.pbf} format. Refer to \code{osmextract::oe_download()} for more details. If not provided OSM Overpass API is called through \code{osmdata::osmdata_sf()}.} } \value{ -An \code{sf} \code{data.frame} object with the following columns: +sf data.frame. Hourly way frequencies, with the following columns: \describe{ \item{way_osm_id}{The \code{osm_id} attribute from OSM way.} \item{hour}{The hour for which the frequency applies (24 hour format).} @@ -45,18 +45,28 @@ This method analyses the GTFS feed for a representative day, finding for each ro For a detailed example, see the \code{vignette("analyse")}. } \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") +\dontshow{if (nzchar(Sys.which("osmium"))) withAutoprint(\{ # examplesIf} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) -# To use OSM API: -frequency_analysis <- GTFShift::get_way_frequency_hourly(gtfs, q) +# Build query and prepare osm extract (possible to use API as alternative) +q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> + osmdata::add_osm_feature(key = "route", value = "bus") |> + osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") -# To use a local OSM file: -osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -frequency_analysis <- GTFShift::get_way_frequency_hourly(gtfs, q, osm_file = osm_file) -} +# Get frequency +frequency_analysis <- GTFShift::get_way_frequency_hourly( + gtfs, q, + date = gtfs$calendar$start_date[1], + osm_file = osm_file +) +head(frequency_analysis |> sf::st_drop_geometry()) +\dontshow{\}) # examplesIf} } \seealso{ \code{GTFShift::calendar_nextBusinessWednesday()} diff --git a/man/load_feed.Rd b/man/load_feed.Rd index 68d2bf8b..90b9bef7 100644 --- a/man/load_feed.Rd +++ b/man/load_feed.Rd @@ -30,7 +30,7 @@ load_feed( \item{headers}{Named list or character vector (Optional). Custom HTTP headers for credentials when accessing the GTFS zip file URL.} } \value{ -A tidygtfs object. +tidygtfs. The loaded GTFS feed. } \description{ Read GTFS feed, fixing integrity errors @@ -47,9 +47,32 @@ the parameters \code{d_limit=transfer_distance}, \code{min_transfer_time=transfe The other parameters are applied the library default values. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("https://operator.com/gtfs.zip") -} +# Simple call +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) + +summary(gtfs) + + +# Simple call with missing shapes (triggering shapes creation because missing on GTFS file) +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +) + +summary(gtfs) + + +# With some parameters to build transfers and store to given location +store_path <- withr::local_tempfile(fileext = ".zip") + +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift"), create_transfers = TRUE, store_path +) + +head(gtfs$transfers) + +file.exists(store_path) } \seealso{ diff --git a/man/multiline_to_sorted_linestring.Rd b/man/multiline_to_sorted_linestring.Rd index ab13c195..50008694 100644 --- a/man/multiline_to_sorted_linestring.Rd +++ b/man/multiline_to_sorted_linestring.Rd @@ -21,7 +21,7 @@ used as iterative tie-break guidance.} \item{metric_crs}{Integer or character (Default 3857). Projected CRS used to compute distances and lengths during sorting.} } \value{ -A \code{sfc} object with LINESTRING geometry. +sfc. LINESTRING geometry object. } \description{ Convert a MULTILINESTRING to a sorted LINESTRING @@ -41,7 +41,7 @@ If guiding points are provided, let \eqn{\mathrm{start\_point}=P_1} be the first \deqn{L^{(1)} = \operatorname*{argmin}_{L \in \mathcal{L}} d(\mathrm{start\_point}, L).} where \eqn{d(\cdot)} is the Euclidean distance. If no points are provided, \eqn{L^{(1)} = L_1} (assuming the input MULTILINESTRING is ordered). -Additionaly, the orientation of \eqn{L^{(1)}} is determined by comparing the distances +Additionally, the orientation of \eqn{L^{(1)}} is determined by comparing the distances from its edges to the remaining segments in \eqn{\mathcal{L} \setminus \{L^{(1)}\}}. The edge that is closest to any remaining segment is designated as the end of \eqn{L^{(1)}}. @@ -75,3 +75,20 @@ unvisited points \eqn{Q} are marked visited when The ordered segments are concatenated into a single \code{LINESTRING} and transformed back to the original CRS of \code{multilinestring}. } +\examples{ +# Get OSM route geometries (MULTILINESTRING) +osm_routes <- sf::st_read( + system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), + quiet = TRUE +) |> dplyr::sample_n(1) + +head(osm_routes) + +# Convert geometry to LINESTRING +osm_routes <- osm_routes |> dplyr::mutate( + geom = GTFShift::multiline_to_sorted_linestring(geom, metric_crs = 3763) +) + +head(osm_routes) + +} diff --git a/man/network_overline.Rd b/man/network_overline.Rd index 888a8023..b350a865 100644 --- a/man/network_overline.Rd +++ b/man/network_overline.Rd @@ -30,7 +30,7 @@ network_overline( \item{metric_crs}{Integer or character (Default 3857). Projected CRS used to compute segment lengths and join distances in meters.} } \value{ -A spatial object of the target network, extended with the aggregated values. +sf. Spatial network object extended with aggregated values. } \description{ Aggregate lines based on overlap with target network @@ -44,16 +44,41 @@ creates an aggregated network based on the lines overlap. Instead, \code{GTFShif segment, the overlapping lines and aggregates their \code{attr} values, using \code{fun}. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("https://operator.com/gtfs.zip") -target_network = st_read("network_centerlines.gpkg") -frequency_analysis <- GTFShift::get_route_frequency_hourly(gtfs, overline=FALSE) -GTFShift::network_overline( - target_network, - frequency_analysis |> filter(arrival_hour==8), - attr = "frequency" +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") ) -} +gtfs <- GTFShift::filter_by_route_name(gtfs, c("4", "1")) + +# Load OSM network to serve as target network +target_network = sf::st_read( + system.file("extdata/samples", "osm_ways_tcb.gpkg", package = "GTFShift"), + quiet = TRUE +) + +head(target_network) + +# Get route frequency (and geometry) +frequency_analysis <- GTFShift::get_route_frequency_hourly( + gtfs, + date = gtfs$calendar$start_date[1] +) |> +dplyr::group_by(shape_id) |> +dplyr::summarize(frequency = max(frequency)) + +head(frequency_analysis) + +# Aggregate frequencies based on geometry overlap using GTFShift::network_overline +suppressWarnings({ + overline <- GTFShift::network_overline( + target_network = target_network, + lines = frequency_analysis, + attr = "frequency", + metric_crs = 3763 # Make sure to addapt to the projection that better suits your location + ) +}) + +head(overline |> st_drop_geometry()) } \seealso{ diff --git a/man/osm_bus_lanes.Rd b/man/osm_bus_lanes.Rd index eb3abaf7..2f2dadc6 100644 --- a/man/osm_bus_lanes.Rd +++ b/man/osm_bus_lanes.Rd @@ -12,7 +12,7 @@ osm_bus_lanes(bbox, osm_file = NULL) \item{osm_file}{character (Optional). Location of OSM extract file with \code{osm.pbf} format. Refer to \code{osmextract::oe_download()} for more details. If not provided OSM Overpass API is called through \code{osmdata::osmdata_sf()}.} } \value{ -osm_lines in sf format +sf data.frame. OSM bus lanes. } \description{ Export designated bus lanes from OpenStreetMaps @@ -21,15 +21,22 @@ Export designated bus lanes from OpenStreetMaps Exports roads tagged as designated bus lanes on OpenStreetMaps for given area. } \examples{ -\dontrun{ -BBOX <- sf::st_bbox(city_limit) +# Create bbox for Lisbon +bbox <- sf::st_as_sfc(sf::st_bbox(c( + xmin = -9.229836, ymin = 38.691399, + xmax = -9.087387, ymax = 38.796760 +), crs = 4326)) -# To use OSM API: -bus_lanes <- GTFShift::osm_bus_lanes(BBOX) +# Use sample osmextract for Lisbon highways +osm_file <- system.file( + "extdata/samples", "osmextract_lisbon_highways_sample.pbf", package = "GTFShift" +) -# To use a local OSM file: -osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -bus_lanes <- GTFShift::osm_bus_lanes(BBOX, osm_file = osm_file) -} +# Export bus lanes +bus_lanes <- GTFShift::osm_bus_lanes(bbox, osm_file = osm_file) + +names(bus_lanes) + +head(bus_lanes |> dplyr::select(`osm:id`, name)) } diff --git a/man/osm_centerlines.Rd b/man/osm_centerlines.Rd index ba32f7dd..cc734377 100644 --- a/man/osm_centerlines.Rd +++ b/man/osm_centerlines.Rd @@ -4,19 +4,27 @@ \alias{osm_centerlines} \title{Get centerlines for OSM road network} \usage{ -osm_centerlines(bbox = NULL, place = NULL, use_buildings = TRUE, venv = NA) +osm_centerlines( + bbox = NULL, + place = NULL, + osm_file = NULL, + use_buildings = TRUE, + venv = NA +) } \arguments{ \item{bbox}{bbox (Optional, if place provided). Area from which to export bus lanes.} \item{place}{String (Optional, if bbox provided). Place from which to export bus lanes.} +\item{osm_file}{String (Optional). Path to a local OpenStreetMap PBF file (`.pbf`).} + \item{use_buildings}{Boolean (Default TRUE). Uses buildings from OSM as exclusion_mask for neatnet.} \item{venv}{String (Default creates a new one). Python environment where neatnet will run.} } \value{ -osm_lines in sf format +sf data.frame. OSM centerlines. } \description{ Get centerlines for OSM road network @@ -25,15 +33,32 @@ Get centerlines for OSM road network Exports road network from OpenStreetMaps for given area and uses Python \href{https://uscuni.org/neatnet/}{neatnet} package to compute its centerlines. -One of \code{bbox} or \code{place} must be provided. If both, \code{bbox} is considered. +One of \code{bbox}, \code{place}, or \code{osm_file} must be provided. Parameter \code{use_buildings} exports building footprints from OSM for better results on the network simplification process. + +This method was adapted from \href{https://uscuni.org/neatnet/intro.html}{uscuni.org/neatnet} +by \href{https://github.com/miguelrelvaspires}{Miguel Relvas Pires} in the scope of +his \href{https://scholar.tecnico.ulisboa.pt/records/DhKWeFU5YLpMDcOhQbKR4f7ul05HCQnZr7ND}{master's thesis}. +The full code (Python) of his work is openly available at +\href{https://github.com/U-Shift/lp_streets}{GitHub}. } \examples{ -\dontrun{ -BBOX = sf::st_bbox(city_limit) -network <- GTFShift::osm_centerlines(BBOX) -} +\dontshow{if (reticulate::py_module_available("neatnet")) withAutoprint(\{ # examplesIf} +# Get sample OSM extract +osm_file <- system.file("extdata/samples", "relation_6384187.pbf", package = "GTFShift") +network <- GTFShift::osm_centerlines( + place = "Arroios, Lisboa, Portugal", + osm_file = osm_file +) + +head(network) + +table(network$X_status) +\dontshow{\}) # examplesIf} +} +\author{ +\href{https://github.com/miguelrelvaspires}{Miguel Relvas Pires} } diff --git a/man/osm_shapes_match_routes.Rd b/man/osm_shapes_match_routes.Rd index f2e2168c..cc2b5132 100644 --- a/man/osm_shapes_match_routes.Rd +++ b/man/osm_shapes_match_routes.Rd @@ -45,7 +45,7 @@ osm_shapes_match_routes( \item{metric_crs}{Integer or character (Default 3857). Projected CRS used to compute shapes and routes lengths and stop-to-stop distances.} } \value{ -A \code{data.frame} (\code{sf} if \code{geometry=TRUE}) with the following columns: +data.frame. Matched routes (\code{sf} if \code{geometry=TRUE}) with the following columns: \describe{ \item{route_id}{The \code{route_id} attribute from \code{routes.txt} file.} \item{shape_id}{The \code{shape_id} attribute from \code{shapes.txt} file.} @@ -117,19 +117,27 @@ an OSM one. This might generate wrong results if the topology of routes on OSM d Refer to \code{distance_diff}, \code{points_diff} and \code{stops_diff} on the results table to validate the results and identify misassociations. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") - -q <- opq("Lisbon") |> - add_osm_feature(key = "route", value = c("bus")) |> - add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) - -# To use OSM API: -shapes_match_routes <- GTFShift::osm_shapes_match_routes(gtfs, q) - -# To use a local OSM file: -osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -shapes_match_routes <- GTFShift::osm_shapes_match_routes(gtfs, q, osm_file = osm_file) -} +\dontshow{if (nzchar(Sys.which("osmium"))) withAutoprint(\{ # examplesIf} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", + package = "GTFShift" +)) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) + +# Build query and prepare osm extract (possible to use API as alternative) +q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> + osmdata::add_osm_feature(key = "route", value = "bus") |> + osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") + +# Get OSM route geometries based on geometrical match +shapes_osm_routes <- GTFShift::osm_shapes_match_routes( + gtfs, q, + osm_file = osm_file, + metric_crs = 3763, # Make sure to addapt to the projection that better suits your location +) +head(shapes_osm_routes |> dplyr::select(shape_id, osm_id, distance_diff, points_diff, stops_diff)) +\dontshow{\}) # examplesIf} } diff --git a/man/osm_shapes_to_routes.Rd b/man/osm_shapes_to_routes.Rd index 77bee6bc..a082747b 100644 --- a/man/osm_shapes_to_routes.Rd +++ b/man/osm_shapes_to_routes.Rd @@ -27,7 +27,7 @@ osm_shapes_to_routes( \item{osm_route_type}{character (Default "bus"). OSM route type. Used to query OSM network (e.g., 'bus', 'train').} } \value{ -A \code{sf} \code{data.frame} with the following columns: +sf data.frame. Matched shape to route geometries with the following columns: \describe{ \item{shape_id}{The \code{shape_id} attribute from \code{shapes.txt} file.} \item{osm_id}{The \code{osm_id} attribute from OSM route relation.} @@ -47,18 +47,38 @@ For each route, matches its trips' shapes with OSM route relations, considering OSM \code{gtfs:shape_id} attribute. } \examples{ -\dontrun{ -gtfs <- GTFShift::load_feed("gtfs.zip") +\dontshow{if (nzchar(Sys.which("osmium"))) withAutoprint(\{ # examplesIf} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("1", "2", "3", "4")) + +# Build query and prepare osm extract (possible to use API as alternative) +q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> + osmdata::add_osm_feature(key = "route", value = "bus") |> + osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") -q <- opq("Lisbon") |> - add_osm_feature(key = "route", value = c("bus")) |> - add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) +# Get OSM route geometries based on gtfs:shape_id match +shapes_osm_routes <- GTFShift::osm_shapes_to_routes( + gtfs, q, + osm_file = osm_file +) -# To use OSM API: -shapes_geometry_osm <- GTFShift::osm_shapes_to_routes(gtfs, q) +head(shapes_osm_routes |> dplyr::select(shape_id, osm_id)) -# To use a local OSM file: -osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -shapes_geometry_osm <- GTFShift::osm_shapes_to_routes(gtfs, q, osm_file = osm_file) -} +nrow(shapes_osm_routes) + +# Get OSM ways instead +shapes_osm_ways <- GTFShift::osm_shapes_to_routes( + gtfs, q, + osm_file = osm_file, + ways = TRUE +) + +head(shapes_osm_ways |> dplyr::select(way_osm_id, shape_id, osm_id)) + +nrow(shapes_osm_ways) +\dontshow{\}) # examplesIf} } diff --git a/man/prioritize_lanes.Rd b/man/prioritise_lanes.Rd similarity index 65% rename from man/prioritize_lanes.Rd rename to man/prioritise_lanes.Rd index 7e841289..edac2deb 100644 --- a/man/prioritize_lanes.Rd +++ b/man/prioritise_lanes.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prioritize_lanes.R -\name{prioritize_lanes} -\alias{prioritize_lanes} -\title{Prioritize road network lanes for bus lane implementation} +% Please edit documentation in R/prioritise_lanes.R +\name{prioritise_lanes} +\alias{prioritise_lanes} +\title{Prioritise road network lanes for bus lane implementation} \usage{ -prioritize_lanes( +prioritise_lanes( gtfs, q, date = GTFShift::calendar_nextBusinessWednesday(), @@ -24,7 +24,7 @@ prioritize_lanes( \item{osm_file}{character (Optional). Location of OSM extract file with \code{osm.pbf} format. Refer to \code{osmextract::oe_download()} for more details. If not provided OSM Overpass API is called through \code{osmdata::osmdata_sf()}.} } \value{ -An \code{sf} \code{data.frame} object with the following columns: +sf data.frame. Prioritised lanes with the following columns: \describe{ \item{way_osm_id}{The \code{osm_id} attribute from OSM way.} \item{hour}{The hour for which the frequency applies (24 hour format).} @@ -41,11 +41,11 @@ An \code{sf} \code{data.frame} object with the following columns: } } \description{ -For each OSM way with GTFS service, aggregates its characteristics to assist in the bus lane implementation prioritization +For each OSM way with GTFS service, aggregates its characteristics to assist in the bus lane implementation prioritisation } \details{ This method analyses the GTFS feed for a representative day, returning a data.frame with the road segments where transit routes -run and for each, a set of parameters that can be used to prioritize bus lane implementations. +run and for each, a set of parameters that can be used to prioritise bus lane implementations. Its functionality is a bundle that encapsulates the logic of several methods from the package, including \code{GTFShift::get_way_frequency_hourly()} and \code{GTFShift::osm_bus_lanes()}, that can be used separately if needed. @@ -54,16 +54,28 @@ Mind that this method uses \code{GTFShift::get_way_frequency_hourly()} to match OSM relation mapping is well defined for the transit routes. Routes that do not have an OSM match are ignored. } \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") +\dontshow{if (nzchar(Sys.which("osmium"))) withAutoprint(\{ # examplesIf} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("4")) -# To use OSM API: -lanes_analysis <- GTFShift::prioritize_lanes(gtfs, q) +# Build query and prepare osm extract (possible to use API as alternative) +q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> + osmdata::add_osm_feature(key = "route", value = "bus") |> + osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") -# To use a local OSM file: -osm_file <- oe_download("https://download.geofabrik.de/europe/portugal-latest.osm.pbf") -lanes_analysis <- GTFShift::prioritize_lanes(gtfs, q, osm_file = osm_file) -} +lane_prioritisation <- GTFShift::prioritise_lanes( + gtfs, q, + osm_file = osm_file, + date = gtfs$calendar$start_date[1] +) +head( + lane_prioritisation |> + dplyr::select(way_osm_id, hour, frequency, is_bus_lane, n_lanes_circulation, routes) +) +\dontshow{\}) # examplesIf} } diff --git a/man/project_points_along_geometry.Rd b/man/project_points_along_geometry.Rd index 784afec4..4ca06bb3 100644 --- a/man/project_points_along_geometry.Rd +++ b/man/project_points_along_geometry.Rd @@ -24,7 +24,7 @@ discretize the line when estimating cumulative distance along geometry.} compute nearest points, line sampling, and cumulative distances.} } \value{ -A data.frame with one row per input point and four columns: +data.frame. Input points projected along geometry with four columns: \describe{ \item{closest_on_geometry}{An \code{sfc_POINT} column with the projected location on the line.} \item{distance_to_closest_on_geometry}{Numeric distance from each input point to its projected location on the line.} @@ -49,14 +49,30 @@ Distances are always computed in \code{metric_crs} units. The returned projected points are transformed back to the original \code{geometry} CRS. } \examples{ -\dontrun{ -line <- sf::st_sfc( - sf::st_linestring(matrix(c(0, 0, 100, 0, 200, 100), ncol = 2, byrow = TRUE)), - crs = 3857 +# Get sample points from GTFS-RT collection +rt_collect_file <- system.file( + "extdata/samples", "gtfs_rt_sample_tcb_4_4-CS-TERM.csv", package = "GTFShift" ) -pts <- sf::st_sfc(sf::st_point(c(20, 10)), sf::st_point(c(150, 40)), crs = 3857) +points <- read.csv(rt_collect_file) |> + sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) |> dplyr::sample_n(5) -projected <- project_points_along_geometry(line, pts, geometry_sample_meters = 5) -} +head(points |> dplyr::select(geometry)) + +# Get route geometry for points +osm_routes <- sf::st_read( + system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), + quiet = TRUE +) |> dplyr::filter(route_id \%in\% points$route_id) + +head(osm_routes) + +# Project points to geometry +points_projected <- GTFShift::project_points_along_geometry( + geometry = osm_routes, + points = points, + metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +) + +head(points_projected) } diff --git a/man/query_mobilitydatabase.Rd b/man/query_mobilitydatabase.Rd index 9f135571..b0083b56 100644 --- a/man/query_mobilitydatabase.Rd +++ b/man/query_mobilitydatabase.Rd @@ -36,10 +36,10 @@ query_mobilitydatabase( \item{bbox}{bbox (Optional). Area from which to get GTFS feeds. Converted to API dataset_latitudes and dataset_longitudes URL parameters.} -\item{is_official.}{Boolean (Optional). If TRUE, only return official feeds.} +\item{is_official}{Boolean (Optional). If TRUE, only return official feeds.} } \value{ -data.frame with query results +data.frame. Query results from Mobility Database. } \description{ Query Mobility Database API for GTFS feeds @@ -57,12 +57,13 @@ Some useful columns of the returned data.frame (refer to the API documentation f } } \examples{ -\dontrun{ +\dontshow{if (nzchar(Sys.getenv("MOBILITY_DATABASE"))) withAutoprint(\{ # examplesIf} feeds <- GTFShift::query_mobilitydatabase( - refresh_token = "myToken", + refresh_token = Sys.getenv("MOBILITY_DATABASE"), country_code = "PT", is_official = TRUE ) -} +head(feeds |> dplyr::select(id, provider, producer_url)) +\dontshow{\}) # examplesIf} } diff --git a/man/rt_average_speed.Rd b/man/rt_average_speed.Rd index eda81404..3a2d2f9c 100644 --- a/man/rt_average_speed.Rd +++ b/man/rt_average_speed.Rd @@ -30,7 +30,7 @@ projecting points along trip geometry and estimating cumulative distance.} compute distances and speeds.} } \value{ -An \code{sf} object based on \code{rt_collection}, with added columns: +sf data.frame. Object based on \code{rt_collection}, with added columns: \describe{ \item{closest_on_shape}{Projected point on trip geometry.} \item{distance_to_closest_on_geometry}{Distance from each update point to its projected location on the shape (meters).} @@ -43,7 +43,7 @@ An \code{sf} object based on \code{rt_collection}, with added columns: } \description{ Projects each real-time vehicle position to its corresponding trip geometry, -computes cumulative distance along the shape, and derives segment speed +computes cumulative distance along the geometry, and derives segment speed between consecutive updates. } \details{ @@ -54,8 +54,8 @@ real-time observations, where \eqn{x_i} is the vehicle position and \eqn{t_1 \le t_2 \le \dots \le t_n}. Each observation is projected onto the trip geometry using \code{GTFShift::project_points_along_geometry()}, yielding a projected point \eqn{\hat{x}_i} and two cumulative distances: -\deqn{d_i = \text{distance_along_geometry}(\hat{x}_i)} -\deqn{d_i^{\mathrm{rev}} = \text{distance_along_geometry_reversed}(\hat{x}_i)} +\deqn{d_i = \text{distance\_along\_geometry}(\hat{x}_i)} +\deqn{d_i^{\mathrm{rev}} = \text{distance\_along\_geometry\_reversed}(\hat{x}_i)} For each pair of consecutive observations \eqn{(i-1, i)}, the elapsed time is computed as @@ -93,11 +93,44 @@ Method \code{GTFShift::multiline_to_sorted_linestring()} can be used to convert geometries to LINESTRING if needed. } \examples{ -\dontrun{ -rt_collection <- read.csv("rt_collection.csv") # sf object with GTFS-RT updates (trip_id, timestamp, geometry) -trips_geometries <- sf::st_read("osm_geometries.gpkg") # sf object with LINESTRING geometry per trip -speeds <- GTFShift::rt_average_speed(rt_collection, trips_geometries) -} +# Get GTFS-RT data collection +rt_collect_file <- system.file( + "extdata/samples", "gtfs_rt_sample_tcb_4_4-CS-TERM.csv", package = "GTFShift" +) +rt_collection <- read.csv(rt_collect_file) |> + sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) |> dplyr::select(-speed) + +head(rt_collection |> dplyr::select(trip_id, timestamp, geometry)) + +nrow(rt_collection) + +# Get route geometry for data collected +osm_routes <- sf::st_read( + system.file("extdata/samples", "osm_routes_tcb.gpkg", package = "GTFShift"), + quiet = TRUE +) |> + dplyr::filter(route_id \%in\% rt_collection$route_id) |> + dplyr::mutate(geom = GTFShift::multiline_to_sorted_linestring(geom, metric_crs = 3763)) + +head(osm_routes) + +# Compute average speed (aggregated at route level) based on cumulative distance along the geometry +speed <- GTFShift::rt_average_speed( + rt_collection = rt_collection, + trips_geometries = osm_routes, + rt_collection_trips_geometries_match_col = "route_id", + metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +) + +head(speed |> + dplyr::filter(!is.na(speed_kmh)) |> + dplyr::select( + trip_id, timestamp, speed_kmh, + distance_along_geometry, distance_to_closest_on_geometry + ) +) + +nrow(speed) } \seealso{ diff --git a/man/rt_collect_json.Rd b/man/rt_collect_json.Rd index dad974dc..b937d536 100644 --- a/man/rt_collect_json.Rd +++ b/man/rt_collect_json.Rd @@ -24,9 +24,9 @@ rt_collect_json( \item{header_key}{String (Default "header"). Key in the JSON corresponding to the feed header. Set to NA if not present.} -\item{entity_key}{String (Default "entity"). Key in the JSON corresponding to the feed entities. Set to NA if response is a flat list.} +\item{entity_key}{String (Default "entity"). Key in the JSON corresponding to the feed entities. Set to NA if response is a flat list. Use "." for nested keys.} -\item{fields_collect}{Character vector. Fields to extract from each entity in the feed.} +\item{fields_collect}{Character vector. Fields to extract from each entity in the feed. Use "." for nested keys.} \item{scrape_interval}{Integer (Default 60). Interval in seconds between each download. Negative to run only once.} @@ -34,6 +34,9 @@ rt_collect_json( \item{headers}{Named list or character vector (Optional). Custom HTTP headers for credentials when accessing the GTFS-RT feed URL.} } +\value{ +String. The location of the file where data was collected. +} \description{ Collect GTFS-RT data from a JSON feed at regular intervals } @@ -43,8 +46,25 @@ Downloads GTFS-RT data from the specified URL at regular intervals and saves the This function will run indefinitely until manually stopped (CTRL + C). } \examples{ -\dontrun{ -GTFShift::rt_collect_json("https://api.example.com/gtfs-rt", "gtfs_rt_data.csv") -} +# Create file +destination_file <- withr::local_tempfile(fileext = ".csv") + +# Collect data +GTFShift::rt_collect_json( + gtfs_rt_url = "https://go.tmlmobilidade.pt/hub/api/v1/realtime/vehicles/positions/gtfs", + entity_key = "data.entity", + destination_file = destination_file, + scrape_interval = -1 # Negative to run only once +) + +# Read data +collection <- read.csv(destination_file) + +names(collection) + +head( + collection |> + dplyr::select("vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude") +) } diff --git a/man/rt_collect_protobuf.Rd b/man/rt_collect_protobuf.Rd index b5fc7803..2c3a307e 100644 --- a/man/rt_collect_protobuf.Rd +++ b/man/rt_collect_protobuf.Rd @@ -28,6 +28,9 @@ rt_collect_protobuf( \item{headers}{Named list or character vector (Optional). Custom HTTP headers for credentials when accessing the GTFS-RT feed URL.} } +\value{ +String. The location of the file where data was collected. +} \description{ Collect GTFS-RT data from a Protocol Buffers feed at regular intervals } @@ -37,8 +40,24 @@ Downloads GTFS-RT data from the specified URL at regular intervals and saves the This function will run indefinitely until manually stopped (CTRL + C). } \examples{ -\dontrun{ -GTFShift::rt_collect_protobuf("https://api.example.com/gtfs-rt-protobuf", "gtfs_rt_data.csv") -} +# Create file +destination_file <- withr::local_tempfile(fileext = ".csv") + +# Collect data +GTFShift::rt_collect_protobuf( + gtfs_rt_url = "https://go.tmlmobilidade.pt/hub/api/v1/realtime/vehicles/positions/gtfs.pb", + destination_file = destination_file, + scrape_interval = -1 # Negative to run only once +) + +# Read data +collection <- read.csv(destination_file) + +names(collection) + +head( + collection |> + dplyr::select("vehicle.trip.trip_id", "vehicle.position.latitude", "vehicle.position.longitude") +) } diff --git a/man/rt_extend_prioritisation.Rd b/man/rt_extend_prioritisation.Rd new file mode 100644 index 00000000..a1508ff3 --- /dev/null +++ b/man/rt_extend_prioritisation.Rd @@ -0,0 +1,89 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rt_extend_prioritisation.R +\name{rt_extend_prioritisation} +\alias{rt_extend_prioritisation} +\title{Extend prioritisation with GTFS-RT based speed metrics} +\usage{ +rt_extend_prioritisation( + lane_prioritisation, + rt_collection, + rt_current_status = c("IN_TRANSIT_TO"), + lane_buffer = 15, + metric_crs = 3857 +) +} +\arguments{ +\item{lane_prioritisation}{sf data.frame. Result of \code{GTFShift::prioritise_lanes()}} + +\item{rt_collection}{sf data.frame. GTFS-RT data collection. Must include \code{speed} column.} + +\item{rt_current_status}{Character vector (Default \code{c("IN_TRANSIT_TO")}). If the \code{current_status} column is present in the \code{rt_collection} data, only points with \code{current_status} in this vector are considered.} + +\item{lane_buffer}{numeric (Default 15). Buffer distance (in meters) to create around lane segments to capture nearby GTFS-RT points.} + +\item{metric_crs}{Integer or character (Default 3857). Projected CRS used to apply lane buffer distances in meters.} +} +\value{ +sf data.frame. Extended lane prioritisation with the following columns: +\describe{ + \item{speed_avg}{The average speed of the vehicles on the way.} + \item{speed_median}{The median speed of the vehicles on the way.} + \item{speed_p25}{The 25th percentile speed of the vehicles on the way.} + \item{speed_p75}{The 75th percentile speed of the vehicles on the way.} + \item{speed_count}{The number of speed observations on the way.} +} +} +\description{ +This function extends lane segment indicators for prioritisation with speed metrics produced with GTFS-RT data. +} +\details{ +Extends the \code{lane_prioritisation} data with speed metrics calculated from the GTFS-RT data points that fall within a buffer around each lane segment. + +If GTFS-RT data does not provide speed information, it can be inferred from the progression of position updates through time using \code{GTFShift::rt_average_speed()}. + +Refer to \code{GTFShift::rt_collect_json()} or \code{GTFShift::rt_collect_protobuf()} for details on GTFS-RT data collection. +} +\examples{ +\dontshow{if (nzchar(Sys.which("osmium"))) withAutoprint(\{ # examplesIf} +# Subset GTFS for one route only, for demo purposes +gtfs <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", + package = "GTFShift" +)) +gtfs <- GTFShift::filter_by_route_name(gtfs, c("4")) + +# Build query and prepare osm extract (possible to use API as alternative) +q <- osmdata::opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> + osmdata::add_osm_feature(key = "route", value = "bus") |> + osmdata::add_osm_feature(key = "operator", value = "Transportes Colectivos do Barreiro") +osm_file <- system.file("extdata/samples", "osmextract_tcb_network.pbf", package = "GTFShift") + +# Prioritise lanes +lane_prioritisation <- GTFShift::prioritise_lanes( + gtfs, q, + osm_file = osm_file, + date = gtfs$calendar$start_date[1] +) + +# Extend with GTFS-RT data collection +rt_collect_file <- system.file( + "extdata/samples", "gtfs_rt_sample_tcb_4_4-CS-TERM.csv", + package = "GTFShift" +) +rt_collection <- read.csv(rt_collect_file) |> + sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) + +lane_prioritisation_extended <- GTFShift::rt_extend_prioritisation( + lane_prioritisation = lane_prioritisation, + rt_collection = rt_collection, + metric_crs = 3763 # Make sure to addapt to the projection that better suits your location +) + +head( + lane_prioritisation_extended |> + sf::st_drop_geometry() |> + dplyr::filter(!is.na(speed_count)) |> + dplyr::select(way_osm_id, speed_avg, speed_count) +) +\dontshow{\}) # examplesIf} +} diff --git a/man/rt_extend_prioritization.Rd b/man/rt_extend_prioritization.Rd deleted file mode 100644 index 593a0d0d..00000000 --- a/man/rt_extend_prioritization.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rt_extend_prioritization.R -\name{rt_extend_prioritization} -\alias{rt_extend_prioritization} -\title{Extend prioritization with GTFS-RT based speed metrics} -\usage{ -rt_extend_prioritization( - lane_prioritization, - rt_collection, - rt_current_status = c("IN_TRANSIT_TO"), - lane_buffer = 15, - metric_crs = 3857 -) -} -\arguments{ -\item{lane_prioritization}{sf data.frame. Result of \code{GTFShift::prioritize_lanes()}} - -\item{rt_collection}{sf data.frame. GTFS-RT data collection. Must include \code{speed} column.} - -\item{rt_current_status}{Character vector (Default \code{c("IN_TRANSIT_TO")}). If the \code{current_status} column is present in the \code{rt_collection} data, only points with \code{current_status} in this vector are considered.} - -\item{lane_buffer}{numeric (Default 15). Buffer distance (in meters) to create around lane segments to capture nearby GTFS-RT points.} - -\item{metric_crs}{Integer or character (Default 3857). Projected CRS used to apply lane buffer distances in meters.} -} -\value{ -The \code{lane_prioritization} \code{sf} \code{data.frame}, extended with the following columns: -\describe{ - \item{speed_avg}{The average speed of the vehicles on the way.} - \item{speed_median}{The median speed of the vehicles on the way.} - \item{speed_p25}{The 25th percentile speed of the vehicles on the way.} - \item{speed_p75}{The 75th percentile speed of the vehicles on the way.} - \item{speed_count}{The number of speed observations on the way.} -} -} -\description{ -This function extends lane segment indicators for prioritization with speed metrics produced with GTFS-RT data. -} -\details{ -Extends the \code{lane_prioritization} data with speed metrics calculated from the GTFS-RT data points that fall within a buffer around each lane segment. - -If GTFS-RT data does not provide speed information, it can be inferred from the progression of position updates through time using \code{GTFShift::rt_average_speed()}. - -Refer to \code{GTFShift::rt_collect_json()} or \code{GTFShift::rt_collect_protobuf()} for details on GTFS-RT data collection. -} -\examples{ -\dontrun{ -rt_collect_file <- "gtfs_rt_data.csv" -GTFShift::rt_collect_json("https://api.example.com/gtfs-rt", rt_collect_file) -lane_prioritization <- GTFShift::prioritize_lanes(gtfs, osm_query) - -rt_collection <- read.csv(rt_collect_file) |> sf::st_as_sf(coords = c("longitude", "latitude"), crs = 4326) -lane_prioritization_extended <- GTFShift::rt_extend_prioritization( - lane_prioritization = lane_prioritization, - rt_collection = rt_collection -) -} - -} diff --git a/man/unify.Rd b/man/unify.Rd index 1656921e..ec0f2fa1 100644 --- a/man/unify.Rd +++ b/man/unify.Rd @@ -30,7 +30,7 @@ unify( \item{transfer_street_routing}{Boolean (Default FALSE). If TRUE, transfer times are calculated by routing throughout the underlying street network (downloaded automatically).} } \value{ -A tidygtfs object. +tidygtfs. The unified GTFS feed. } \description{ Merge multiple GTFS into a single aggregated file @@ -47,11 +47,35 @@ with the parameters \code{d_limit=transfer_distance}, \code{min_transfer_time=tr For a detailed example, see the \code{vignette("unify")}. } \examples{ -\dontrun{ -gtfs1 <- GTFShift::load_feed("gtfs1.zip") -gtfs2 <- GTFShift::load_feed("gtfs2.zip") -unified <- GTFShift::unify(gtfs1, gtfs2, create_transfers = TRUE) -} +# Load multiple GTFS files +gtfs_1 <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_tcb_sample.zip", package = "GTFShift") +) + +summary(gtfs_1) + +gtfs_1$agency + +head(gtfs_1$trips) + +gtfs_2 <- GTFShift::load_feed(system.file("extdata/samples", + "gtfs_ttsl_sample_no_shapes.zip", package = "GTFShift") +) + +summary(gtfs_2) + +gtfs_2$agency + +head(gtfs_2$trips) + +# Unify them +unified <- GTFShift::unify(gtfs_1, gtfs_2, prefix = TRUE) + +summary(unified) + +unified$agency + +head(unified$trips) } \seealso{ diff --git a/tests/spelling.R b/tests/spelling.R new file mode 100644 index 00000000..6713838f --- /dev/null +++ b/tests/spelling.R @@ -0,0 +1,3 @@ +if(requireNamespace('spelling', quietly = TRUE)) + spelling::spell_check_test(vignettes = TRUE, error = FALSE, + skip_on_cran = TRUE) diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 00000000..c485944b --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,4 @@ +library(testthat) +library(GTFShift) + +test_check("GTFShift") diff --git a/tests/testthat/test-calendar_utils.R b/tests/testthat/test-calendar_utils.R new file mode 100644 index 00000000..99f20f2a --- /dev/null +++ b/tests/testthat/test-calendar_utils.R @@ -0,0 +1,85 @@ +library(testthat) + +test_that("calendar_nextBusinessWednesday computes next Wednesday without network call when country_code is NA", { + start_date <- as.Date("2026-07-20") # Monday + next_wed <- GTFShift::calendar_nextBusinessWednesday(start_date = start_date, country_code = NA) + expect_equal(next_wed, as.Date("2026-07-22")) +}) + +test_that("calendar_nextBusinessWednesday fetches new year holidays when next Wednesday triggers new year", { + # 2026-12-30 is Wednesday. If 2026-12-30 is a holiday, the next Wednesday is 2027-01-06 (new year) + start_date <- as.Date("2026-12-28") # Monday + called_years <- c() + + testthat::with_mocked_bindings( + GET = function(url, ...) { + # Extract year from URL https://date.nager.at/api/v3/PublicHolidays/{year}/{country} + yr <- gsub(".*/PublicHolidays/([0-9]+)/.*", "\\1", url) + called_years <<- c(called_years, yr) + + content_json <- if (yr == "2026") '[{"date":"2026-12-30"}]' else '[]' + structure( + list( + status_code = 200, + url = url, + headers = list("Content-Type" = "application/json"), + content = charToRaw(content_json) + ), + class = "response" + ) + }, + .package = "httr", + code = { + next_wed <- GTFShift::calendar_nextBusinessWednesday(start_date = start_date, country_code = "PT") + expect_equal(next_wed, as.Date("2027-01-06")) + } + ) + + expect_equal(called_years, c("2026", "2027")) +}) + +test_that("calendar_nextBusinessWednesday handles mocked holiday response", { + start_date <- as.Date("2026-07-20") # Monday + + testthat::with_mocked_bindings( + GET = function(url, ...) { + structure( + list( + status_code = 200, + url = url, + headers = list("Content-Type" = "application/json"), + content = charToRaw('[{"date":"2026-07-22"}]') + ), + class = "response" + ) + }, + .package = "httr", + code = { + next_wed <- GTFShift::calendar_nextBusinessWednesday(start_date = start_date, country_code = "PT") + expect_equal(next_wed, as.Date("2026-07-29")) + } + ) +}) + +test_that("calendar_nextBusinessWednesday stops when API does not respond with status 200", { + start_date <- as.Date("2026-07-20") # Monday + + testthat::with_mocked_bindings( + GET = function(url, ...) { + structure( + list( + status_code = 500, + url = url + ), + class = "response" + ) + }, + .package = "httr", + code = { + expect_error( + GTFShift::calendar_nextBusinessWednesday(start_date = start_date, country_code = "PT"), + "Failed to retrieve holidays. Please check your internet connection or API availability." + ) + } + ) +}) diff --git a/tests/testthat/test-classify_frequency_los.R b/tests/testthat/test-classify_frequency_los.R new file mode 100644 index 00000000..60ad2474 --- /dev/null +++ b/tests/testthat/test-classify_frequency_los.R @@ -0,0 +1,9 @@ +library(testthat) + +test_that("classify_frequency_los assigns correct HCM level of service categories", { + df <- data.frame(frequency = c(0, 1, 2, 4, 6, 8)) + res <- GTFShift::classify_frequency_los(df) + + expect_contains(names(res), "frequency_los") + expect_equal(res$frequency_los, c("F", "E", "D", "C", "B", "A")) +}) diff --git a/tests/testthat/test-create_calendar.R b/tests/testthat/test-create_calendar.R new file mode 100644 index 00000000..de07d0d8 --- /dev/null +++ b/tests/testthat/test-create_calendar.R @@ -0,0 +1,13 @@ +library(testthat) + +test_that("create_calendar generates calendar table from calendar_dates", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + cal <- GTFShift::create_calendar(gtfs) + expect_true(is.data.frame(cal)) + expect_contains(names(cal), c("service_id", "monday", "tuesday", "start_date", "end_date")) + + service_ids <- gtfs$calendar_dates |> filter(exception_type == 1) |> pull(service_id) |> unique() + expect_equal(sort(unique(cal$service_id)), sort(service_ids)) +}) diff --git a/tests/testthat/test-create_shapes_from_sf.R b/tests/testthat/test-create_shapes_from_sf.R new file mode 100644 index 00000000..c9646a7b --- /dev/null +++ b/tests/testthat/test-create_shapes_from_sf.R @@ -0,0 +1,77 @@ +library(testthat) +library(sf) + +test_that("create_shapes_from_sf generates shapes from sf object", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + sf_line <- st_sf( + shape_id = target_shape_id, + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + shapes_df <- GTFShift::create_shapes_from_sf(sf_line, gtfs, metric_crs = 3857) + expect_contains(names(shapes_df), c("shape_id", "shape_pt_lat", "shape_pt_lon", "shape_pt_sequence")) + expect_gt(nrow(shapes_df), 1) + expect_equal(shapes_df$shape_id[1], target_shape_id) +}) + +test_that("create_shapes_from_sf calculates shape_dist_traveled when shape_dist_traveled = TRUE", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + unmatched_shape_id <- "non_existent_shape_id" + + sf_lines <- st_sf( + shape_id = c(target_shape_id, unmatched_shape_id), + geometry = st_sfc( + st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), + st_linestring(matrix(c(-8.65, -8.66, 41.15, 41.16), ncol = 2)), + crs = 4326 + ) + ) + + expected_dist <- as.numeric(st_length(st_transform(sf_lines[1, ], 3857))) + + shapes_df <- GTFShift::create_shapes_from_sf(sf_lines, gtfs, metric_crs = 3857, shape_dist_traveled = TRUE) + expect_contains(names(shapes_df), c("shape_id", "shape_pt_lat", "shape_pt_lon", "shape_pt_sequence", "shape_dist_traveled")) + expect_false(any(is.na(shapes_df$shape_dist_traveled))) + expect_equal(shapes_df$shape_dist_traveled[1], 0) + expect_equal(shapes_df$shape_dist_traveled[2], expected_dist, tolerance = 1e-3) + + # Validate that unmatched_shape_id was ignored and not present in shapes_df + expect_false(unmatched_shape_id %in% shapes_df$shape_id) +}) + +test_that("create_shapes_from_sf issues warning when metric_crs is missing", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + sf_line <- st_sf( + shape_id = target_shape_id, + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + expect_warning( + GTFShift::create_shapes_from_sf(sf_line, gtfs), + "Using default metric_crs" + ) +}) + +test_that("create_shapes_from_sf stops when shape_id column is missing", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + sf_line_no_id <- st_sf( + invalid_id = "123", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + expect_error( + GTFShift::create_shapes_from_sf(sf_line_no_id, gtfs, metric_crs = 3857), + "The sf_shapes object must contain a \"shape_id\" column." + ) +}) diff --git a/tests/testthat/test-create_shapes_from_stops.R b/tests/testthat/test-create_shapes_from_stops.R new file mode 100644 index 00000000..87508a57 --- /dev/null +++ b/tests/testthat/test-create_shapes_from_stops.R @@ -0,0 +1,28 @@ +library(testthat) + +test_that("create_shapes_from_stops constructs shape geometries from stop sequences", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + expect_warning( + res_gtfs <- GTFShift::create_shapes_from_stops(gtfs), + "The GTFS feed already has shapes defined" + ) + + expect_contains(names(res_gtfs), "shapes") + expect_contains(names(res_gtfs$shapes), c("shape_id", "shape_pt_lat", "shape_pt_lon", "shape_pt_sequence")) + + # Select a target shape_id and validate that its shape point count equals the stop count of a trip sharing that shape + target_shape_id <- res_gtfs$shapes$shape_id[1] + matching_trip_id <- res_gtfs$trips$trip_id[res_gtfs$trips$shape_id == target_shape_id][1] + + shape_points_count <- sum(res_gtfs$shapes$shape_id == target_shape_id) + trip_stops_count <- sum(gtfs$stop_times$trip_id == matching_trip_id) + + expect_equal(shape_points_count, trip_stops_count) + + # Make sure trips table has shape_id, but keeps other columns + expect_equal(sort(unique(res_gtfs$trips$shape_id)), sort(unique(res_gtfs$shapes$shape_id))) + expect_equivalent(sort(colnames(res_gtfs$trips)), sort(unique(colnames(gtfs$trips), "shape_id"))) + expect_equal(nrow(gtfs$trips), nrow(res_gtfs$trips)) +}) diff --git a/tests/testthat/test-filter_by_agency.R b/tests/testthat/test-filter_by_agency.R new file mode 100644 index 00000000..3dc6afb3 --- /dev/null +++ b/tests/testthat/test-filter_by_agency.R @@ -0,0 +1,27 @@ +library(testthat) + +test_that("filter_by_agency filters by id and name using merged feed sample", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + agencies <- gtfs$agency$agency_name + agency_id_target <- gtfs$agency$agency_id[1] + agency_name_target <- gtfs$agency$agency_name[1] + + # Filter by ID + gtfs_by_id <- GTFShift::filter_by_agency(gtfs, id = agency_id_target) + testthat::expect_contains(class(gtfs_by_id), "tidygtfs") + testthat::expect_equal(unique(gtfs_by_id$agency$agency_id), agency_id_target) + + # Filter by Name + gtfs_by_name <- GTFShift::filter_by_agency(gtfs, name = agency_name_target) + testthat::expect_equal(unique(gtfs_by_name$agency$agency_name), agency_name_target) +}) + + +test_that("filter_by_agency returns empty result when query does not match", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + gtfs_empty <- GTFShift::filter_by_agency(gtfs, id = "non_existent_agency_id_9999") + testthat::expect_equal(nrow(gtfs_empty$agency), 0) +}) diff --git a/tests/testthat/test-filter_by_mode.R b/tests/testthat/test-filter_by_mode.R new file mode 100644 index 00000000..83ad12af --- /dev/null +++ b/tests/testthat/test-filter_by_mode.R @@ -0,0 +1,36 @@ +library(testthat) + +test_that("filter_by_modes filters routes by mode code", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + # agency_id 8 (TCB) has bus routes (route_type 3) and agency 4 (TTSL) has ferry routes (route_type 4) + gtfs <- GTFShift::load_feed(sample_file) + + # Filter for bus routes (mode 3) + gtfs_bus <- GTFShift::filter_by_modes(gtfs, modes = list(3)) + expect_contains(class(gtfs_bus), "tidygtfs") + expect_true(all(gtfs_bus$routes$route_type == 3)) + expect_gt(nrow(gtfs_bus$routes), 0) + + # Filter for ferry routes (mode 4) + gtfs_ferry <- GTFShift::filter_by_modes(gtfs, modes = list(4)) + expect_contains(class(gtfs_ferry), "tidygtfs") + expect_true(all(gtfs_ferry$routes$route_type == 4)) + expect_gt(nrow(gtfs_ferry$routes), 0) + + # Filter for multiple modes (3 and 4) + gtfs_multi <- GTFShift::filter_by_modes(gtfs, modes = list(3, 4)) + expect_contains(class(gtfs_multi), "tidygtfs") + expect_true(all(gtfs_multi$routes$route_type %in% c(3, 4))) + expect_equal(nrow(gtfs_multi$routes), nrow(gtfs_bus$routes) + nrow(gtfs_ferry$routes)) +}) + +test_that("filter_by_modes returns empty feed when no routes match mode code", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + # Mode 999 does not exist in sample + gtfs_empty <- GTFShift::filter_by_modes(gtfs, modes = list(999)) + expect_contains(class(gtfs_empty), "tidygtfs") + expect_equal(nrow(gtfs_empty$routes), 0) + expect_equal(nrow(gtfs_empty$trips), 0) +}) diff --git a/tests/testthat/test-filter_by_route_name.R b/tests/testthat/test-filter_by_route_name.R new file mode 100644 index 00000000..f6892906 --- /dev/null +++ b/tests/testthat/test-filter_by_route_name.R @@ -0,0 +1,44 @@ +library(testthat) + +test_that("filter_by_route_name filters by short name exact match", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + short_target <- gtfs$routes$route_short_name[1] + gtfs_short_exact <- GTFShift::filter_by_route_name(gtfs, values = list(short_target), short_name = TRUE, exact_match = TRUE) + expect_contains(class(gtfs_short_exact), "tidygtfs") + expect_equal(unique(gtfs_short_exact$routes$route_short_name), short_target) +}) + +test_that("filter_by_route_name filters by short name partial match", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + short_target <- gtfs$routes$route_short_name[1] + short_partial <- substr(short_target, 1, 1) + gtfs_short_partial <- GTFShift::filter_by_route_name(gtfs, values = list(short_partial), short_name = TRUE, exact_match = FALSE) + expect_contains(class(gtfs_short_partial), "tidygtfs") + expect_true(all(grepl(short_partial, gtfs_short_partial$routes$route_short_name, ignore.case = TRUE))) +}) + +test_that("filter_by_route_name filters by long name exact match", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + long_target <- gtfs$routes$route_long_name[1] + gtfs_long_exact <- GTFShift::filter_by_route_name(gtfs, values = list(long_target), short_name = FALSE, exact_match = TRUE) + expect_contains(class(gtfs_long_exact), "tidygtfs") + expect_equal(unique(gtfs_long_exact$routes$route_long_name), long_target) +}) + +test_that("filter_by_route_name filters by long name partial match", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + long_target <- gtfs$routes$route_long_name[1] + long_words <- unlist(strsplit(long_target, "\\s+")) + long_partial <- long_words[1] + gtfs_long_partial <- GTFShift::filter_by_route_name(gtfs, values = list(long_partial), short_name = FALSE, exact_match = FALSE) + expect_contains(class(gtfs_long_partial), "tidygtfs") + expect_true(all(grepl(long_partial, gtfs_long_partial$routes$route_long_name, ignore.case = TRUE))) +}) diff --git a/tests/testthat/test-get_network_extension.R b/tests/testthat/test-get_network_extension.R new file mode 100644 index 00000000..c31402d8 --- /dev/null +++ b/tests/testthat/test-get_network_extension.R @@ -0,0 +1,96 @@ +library(testthat) + +test_that("get_network_extension calculates network route extension in meters", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + ext <- GTFShift::get_network_extension(gtfs, date = ref_date, metric_crs = 3857) + expect_true(is.numeric(ext) || inherits(ext, "units")) + expect_gt(as.numeric(ext), 0) +}) + +test_that("get_network_extension throws error for invalid route_identifier", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + ref_date <- gtfs$calendar$start_date[1] + + expect_error( + GTFShift::get_network_extension(gtfs, route_identifier = "invalid_id", date = ref_date, metric_crs = 3857), + "route_identifier should be one of: route_id, route_short_name or route_long_name" + ) +}) + +test_that("get_network_extension throws error for invalid metric_crs", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + ref_date <- gtfs$calendar$start_date[1] + + expect_error( + GTFShift::get_network_extension(gtfs, date = ref_date, metric_crs = NA), + "metric_crs should be a valid CRS value" + ) +}) + +test_that("get_network_extension issues warning when metric_crs is missing", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + ref_date <- gtfs$calendar$start_date[1] + + expect_warning( + GTFShift::get_network_extension(gtfs, date = ref_date), + "Using default metric_crs" + ) +}) + +test_that("get_network_extension works with parameter variations", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + ref_date <- gtfs$calendar$start_date[1] + + # Variation 1: direction_wise = FALSE + ext_dir_false <- GTFShift::get_network_extension( + gtfs, + date = ref_date, + direction_wise = FALSE, + metric_crs = 3857 + ) + expect_gt(as.numeric(ext_dir_false), 0) + + # Variation 2: unified = TRUE + ext_unified <- GTFShift::get_network_extension( + gtfs, + date = ref_date, + unified = TRUE, + metric_crs = 3857 + ) + expect_gt(as.numeric(ext_unified), 0) + + # Unified extension should be less than or equal to non-unified extension + ext_non_unified <- GTFShift::get_network_extension( + gtfs, + date = ref_date, + unified = FALSE, + metric_crs = 3857 + ) + expect_lte(as.numeric(ext_unified), as.numeric(ext_non_unified)) + + # Variation 3: alternative valid route_identifier + ext_short_name <- GTFShift::get_network_extension( + gtfs, + route_identifier = "route_short_name", + date = ref_date, + metric_crs = 3857 + ) + expect_gt(as.numeric(ext_short_name), 0) + + # Variation 4: alternative character metric_crs + ext_epsg_str <- GTFShift::get_network_extension( + gtfs, + date = ref_date, + metric_crs = "EPSG:3857" + ) + expect_equal(as.numeric(ext_epsg_str), as.numeric(ext_non_unified)) +}) + diff --git a/tests/testthat/test-get_prioritisation_stats.R b/tests/testthat/test-get_prioritisation_stats.R new file mode 100644 index 00000000..c6842e0a --- /dev/null +++ b/tests/testthat/test-get_prioritisation_stats.R @@ -0,0 +1,150 @@ +library(testthat) +library(sf) + +test_that("get_prioritisation_stats calculates summary statistics without speed_avg", { + prioritisation_df <- st_sf( + is_bus_lane = c(TRUE, FALSE), + frequency = c(10, 5), + n_lanes_circulation = c(2, 4), + n_lanes_parking = c(1, 3), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), # 100 m + st_linestring(matrix(c(100, 0, 300, 0), ncol = 2, byrow = TRUE)), # 200 m + crs = 3857 + ) + ) + + stats <- GTFShift::get_prioritisation_stats(prioritisation_df, weight = "length", metric_crs = 3857) + expect_type(stats, "list") + expect_contains(names(stats), c("extension", "extension_bus_lane", "n_lanes_circulation_avg", "n_lanes_parking_avg")) + + # Internal length mutation: feature 1 = 100m, feature 2 = 200m + # extension: total length = 300m + expect_equal(stats$extension, 300) + # extension_bus_lane: only feature 1 is bus lane -> 100m + expect_equal(stats$extension_bus_lane, 100) + + # Weighted mean by length (weights: 100 and 200, total = 300): + # n_lanes_circulation: (2*100 + 4*200) / 300 = (200 + 800) / 300 = 10/3 + expect_equal(stats$n_lanes_circulation_avg, 10 / 3) + expect_equal(stats$n_lanes_circulation_min, 2) + expect_equal(stats$n_lanes_circulation_max, 4) + + # n_lanes_parking: (1*100 + 3*200) / 300 = (100 + 600) / 300 = 7/3 + expect_equal(stats$n_lanes_parking_avg, 7 / 3) + expect_equal(stats$n_lanes_parking_min, 1) + expect_equal(stats$n_lanes_parking_max, 3) + + # Validate that speed metrics are NOT present when speed_avg column is missing + expect_false(any(c("speed_avg", "speed_min", "speed_max") %in% names(stats))) +}) + +test_that("get_prioritisation_stats calculates speed metrics when speed_avg column is present", { + prioritisation_df <- st_sf( + is_bus_lane = c(TRUE, FALSE), + frequency = c(10, 5), + speed_avg = c(30, 50), + n_lanes_circulation = c(2, 3), + n_lanes_parking = c(1, 0), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 200, 0), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + ) + + # Test with weight = "frequency" (weights: 10 and 5, total = 15) + stats <- GTFShift::get_prioritisation_stats(prioritisation_df, weight = "frequency", metric_crs = 3857) + expect_type(stats, "list") + expect_contains(names(stats), c("speed_avg", "speed_min", "speed_max")) + + # speed_avg weighted by frequency: (30*10 + 50*5) / 15 = 550 / 15 = 36.66667 + expect_equal(stats$speed_avg, (30 * 10 + 50 * 5) / 15) + expect_equal(stats$speed_min, 30) + expect_equal(stats$speed_max, 50) + + # n_lanes_circulation weighted by frequency: (2*10 + 3*5) / 15 = 35 / 15 = 7/3 + expect_equal(stats$n_lanes_circulation_avg, 35 / 15) + expect_equal(stats$n_lanes_circulation_min, 2) + expect_equal(stats$n_lanes_circulation_max, 3) + + # n_lanes_parking weighted by frequency: (1*10 + 0*5) / 15 = 10 / 15 = 2/3 + expect_equal(stats$n_lanes_parking_avg, 10 / 15) + expect_equal(stats$n_lanes_parking_min, 0) + expect_equal(stats$n_lanes_parking_max, 1) +}) + +test_that("get_prioritisation_stats raises warning when metric_crs is default", { + prioritisation_df <- st_sf( + is_bus_lane = c(TRUE, FALSE), + frequency = c(10, 5), + n_lanes_circulation = c(2, 3), + n_lanes_parking = c(1, 0), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 200, 0), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + ) + + expect_warning( + GTFShift::get_prioritisation_stats(prioritisation_df, weight = "length"), + "Using default metric_crs" + ) +}) + +test_that("get_prioritisation_stats stops on invalid weight or metric_crs", { + prioritisation_df <- st_sf( + is_bus_lane = c(TRUE, FALSE), + frequency = c(10, 5), + n_lanes_circulation = c(2, 3), + n_lanes_parking = c(1, 0), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 200, 0), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + ) + + # Invalid weight choice + expect_error( + GTFShift::get_prioritisation_stats(prioritisation_df, weight = "invalid_weight", metric_crs = 3857) + ) + + # Invalid CRS + expect_error( + GTFShift::get_prioritisation_stats(prioritisation_df, weight = "length", metric_crs = NA), + "metric_crs should be a valid CRS value" + ) +}) + +test_that("get_prioritisation_stats calculates stats using weight = 'length' vs weight = 'frequency'", { + # Feature 1: length = 100m, frequency = 30, speed_avg = 20, n_lanes_circulation = 2 + # Feature 2: length = 300m, frequency = 10, speed_avg = 60, n_lanes_circulation = 4 + prioritisation_df <- st_sf( + is_bus_lane = c(TRUE, FALSE), + frequency = c(30, 10), + speed_avg = c(20, 60), + n_lanes_circulation = c(2, 4), + n_lanes_parking = c(1, 3), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 400, 0), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + ) + + # 1) Weight by length (weights: 100 and 300, total = 400) + stats_length <- GTFShift::get_prioritisation_stats(prioritisation_df, weight = "length", metric_crs = 3857) + # speed_avg: (20*100 + 60*300) / 400 = (2000 + 18000) / 400 = 50 + expect_equal(stats_length$speed_avg, 50) + # n_lanes_circulation_avg: (2*100 + 4*300) / 400 = (200 + 1200) / 400 = 3.5 + expect_equal(stats_length$n_lanes_circulation_avg, 3.5) + + # 2) Weight by frequency (weights: 30 and 10, total = 40) + stats_freq <- GTFShift::get_prioritisation_stats(prioritisation_df, weight = "frequency", metric_crs = 3857) + # speed_avg: (20*30 + 60*10) / 40 = (600 + 600) / 40 = 30 + expect_equal(stats_freq$speed_avg, 30) + # n_lanes_circulation_avg: (2*30 + 4*10) / 40 = (60 + 40) / 40 = 2.5 + expect_equal(stats_freq$n_lanes_circulation_avg, 2.5) +}) diff --git a/tests/testthat/test-get_route_frequency_hourly.R b/tests/testthat/test-get_route_frequency_hourly.R new file mode 100644 index 00000000..265610f6 --- /dev/null +++ b/tests/testthat/test-get_route_frequency_hourly.R @@ -0,0 +1,55 @@ +library(testthat) + +test_that("get_route_frequency_hourly calculates route frequencies", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + res <- GTFShift::get_route_frequency_hourly(gtfs, date = ref_date) + expect_s3_class(res, "sf") + expect_contains(names(res), c("frequency", "hour", "geometry", "route_id", "route_short_name", "shape_id")) +}) + +test_that("get_route_frequency_hourly supports overline = TRUE", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + res <- GTFShift::get_route_frequency_hourly(gtfs, date = ref_date, overline = TRUE) + expect_s3_class(res, "sf") + expect_contains(names(res), c("frequency", "hour", "geometry")) + + res_no_overline <- GTFShift::get_route_frequency_hourly(gtfs, date = ref_date, overline = FALSE) + expect_gt(nrow(res), nrow(res_no_overline)) +}) + +test_that("get_route_frequency_hourly supports use_osm_routes != NA", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + mock_shapes <- sf::st_sf( + shape_id = unique(gtfs$trips$shape_id[!is.na(gtfs$trips$shape_id)]), + geometry = sf::st_sfc( + lapply( + seq_along(unique(gtfs$trips$shape_id[!is.na(gtfs$trips$shape_id)])), + function(i) sf::st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)) + ), + crs = 4326 + ) + ) + + testthat::with_mocked_bindings( + osm_shapes_to_routes = function(...) mock_shapes, + .package = "GTFShift", + code = { + res <- GTFShift::get_route_frequency_hourly(gtfs, date = ref_date, use_osm_routes = "mock_opq") + expect_s3_class(res, "sf") + expect_contains(names(res), c("frequency", "hour")) + } + ) +}) + diff --git a/tests/testthat/test-get_stop_frequency_hourly.R b/tests/testthat/test-get_stop_frequency_hourly.R new file mode 100644 index 00000000..1dabd1d4 --- /dev/null +++ b/tests/testthat/test-get_stop_frequency_hourly.R @@ -0,0 +1,43 @@ +library(testthat) + +test_that("get_stop_frequency_hourly calculates stop departures per hour", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + res <- GTFShift::get_stop_frequency_hourly(gtfs, date = ref_date) + expect_s3_class(res, "sf") + expect_contains(names(res), c("stop_id", "hour", "frequency", "geometry")) + + # Validate frequency calculation for a selected stop against filtered stop_times + target_stop_id <- res$stop_id[1] + calculated_stop_freq <- res |> + sf::st_drop_geometry() |> + dplyr::filter(stop_id == target_stop_id) |> + dplyr::arrange(hour) + + suppressWarnings({ # tidytransit will warn about no transfers + gtfs_date <- tidytransit::filter_feed_by_date(gtfs, extract_date = ref_date) + }) + pattern_gtfs <- tidytransit::set_servicepattern(gtfs_date) + service_pattern_ids <- pattern_gtfs$.$dates_servicepatterns |> + dplyr::filter(date == ref_date) + service_ids <- pattern_gtfs$.$servicepattern |> + dplyr::filter(servicepattern_id %in% service_pattern_ids$servicepattern_id) |> + dplyr::pull(service_id) + + # Filter trips matching active service_ids for the date + active_trips <- gtfs_date$trips |> + dplyr::filter(service_id %in% service_ids) + + expected_stop_freq <- gtfs_date$stop_times |> + dplyr::filter(stop_id == target_stop_id, trip_id %in% active_trips$trip_id) |> + dplyr::mutate(hour = lubridate::hour(departure_time)) |> + dplyr::group_by(hour) |> + dplyr::summarise(expected_freq = dplyr::n()) |> + dplyr::filter(hour %in% calculated_stop_freq$hour) |> + dplyr::arrange(hour) + + expect_equal(calculated_stop_freq$frequency, expected_stop_freq$expected_freq) +}) diff --git a/tests/testthat/test-get_way_frequency_hourly.R b/tests/testthat/test-get_way_frequency_hourly.R new file mode 100644 index 00000000..8e7d105b --- /dev/null +++ b/tests/testthat/test-get_way_frequency_hourly.R @@ -0,0 +1,46 @@ +library(testthat) +library(sf) + +test_that("get_way_frequency_hourly calculates way frequencies with mocked osm_shapes_to_routes", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + # Calculate route frequencies to select an active shape_id with departures + route_freq <- GTFShift::get_route_frequency_hourly(gtfs, date = ref_date) + target_shape_id <- route_freq$shape_id[1] + expected_freq_by_hour <- route_freq |> + sf::st_drop_geometry() |> + dplyr::filter(shape_id == target_shape_id) |> + dplyr::group_by(hour) |> + dplyr::summarise(total_freq = sum(frequency)) + + mock_line <- st_sf( + shape_id = target_shape_id, + way_osm_id = "12345", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), crs = 4326) + ) + + testthat::with_mocked_bindings( + osm_shapes_to_routes = function(...) { + mock_line + }, + .package = "GTFShift", + code = { + res <- GTFShift::get_way_frequency_hourly(gtfs, q = NA, date = ref_date) + expect_s3_class(res, "sf") + expect_contains(names(res), c("way_osm_id", "frequency", "geometry", "routes", "shapes")) + + # Validate that the way frequency matches the route frequency for the selected shape + way_freq_by_hour <- res |> + sf::st_drop_geometry() |> + dplyr::filter(way_osm_id == "12345") |> + dplyr::group_by(hour) |> + dplyr::summarise(total_freq = sum(frequency)) + + expect_equal(way_freq_by_hour$total_freq, expected_freq_by_hour$total_freq) + expect_equal(way_freq_by_hour$hour, expected_freq_by_hour$hour) + } + ) +}) diff --git a/tests/testthat/test-load_feed.R b/tests/testthat/test-load_feed.R new file mode 100644 index 00000000..68b14497 --- /dev/null +++ b/tests/testthat/test-load_feed.R @@ -0,0 +1,105 @@ +library(testthat) + +test_that("gtfs simple load", { + gtfs <- GTFShift::load_feed(system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift")) + testthat::expect_contains(class(gtfs), "tidygtfs") + testthat::expect_contains(class(gtfs), "gtfs") + testthat::expect_contains(class(gtfs), "list") + testthat::expect_contains(names(gtfs), "agency") + testthat::expect_contains(names(gtfs), "routes") + testthat::expect_contains(names(gtfs), "trips") + testthat::expect_contains(names(gtfs), "stops") + testthat::expect_contains(names(gtfs), "stop_times") + testthat::expect_contains(names(gtfs), "shapes") +}) + +test_that("stores file at defined location", { + tempfolder <- withr::local_tempdir() + location <- paste0(tempfolder, "/new_dir/gtfs_tcb_sample.zip") + gtfs <- GTFShift::load_feed( + system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift"), + store_path = location + ) + testthat::expect_true(file.exists(location)) + testthat::expect_true(file.size(location) > 0) + testthat::expect_contains(class(gtfs), "tidygtfs") + zip::zip_list(location) |> + dplyr::pull(filename) |> + testthat::expect_contains(c("agency.txt", "routes.txt", "trips.txt", "stops.txt", "stop_times.txt", "shapes.txt")) +}) + +test_that("creates transfers", { + gtfs <- GTFShift::load_feed(system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift"), create_transfers = TRUE) + testthat::expect_contains(names(gtfs), "transfers") + testthat::expect_gte(nrow(gtfs$transfers), 1) +}) + +test_that("clean empty stop_times", { + gtfs <- GTFShift::load_feed(system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift"), create_transfers = TRUE) + random_trip = gtfs$trips |> sample_n(1) |> pull(trip_id) + gtfs$stop_times[random_trip == gtfs$stop_times$trip_id, ][1, ]$arrival_time <- NA + location = withr::local_tempfile(fileext = ".zip") + tidytransit::write_gtfs(gtfs, location) + testthat::expect_warning(gtfs_new <- GTFShift::load_feed(location), "without arrival time") +}) + +test_that("creates shapes when missing", { + gtfs <- GTFShift::load_feed(system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift")) + gtfs_manipulated <- gtfs[!names(gtfs) %in% "shapes"] + gtfs_manipulated <- tidytransit::as_tidygtfs(gtfs_manipulated) + gtfs_manipulated$trips <- gtfs_manipulated$trips[, !names(gtfs_manipulated$trips) %in% "shape_id"] + location <- withr::local_tempfile(fileext = ".zip") + tidytransit::write_gtfs(gtfs_manipulated, location) + testthat::expect_warning(gtfs_new <- GTFShift::load_feed(location), "CREATED shapes.txt") + testthat::expect_contains(names(gtfs_new), "shapes") + testthat::expect_gte(nrow(gtfs_new$shapes), 1) + testthat::expect_true(all(names(gtfs_new$shapes) %in% names(gtfs$shapes))) +}) + +test_that("headers set when calling remote gtfs url", { + API_KEY <- "ash84r" + headers <- c("X-App-Id" = API_KEY) + URL <- "http://example.com/gtfs.zip" + + captured_url <- NULL + captured_headers <- NULL + + sample_gtfs <- structure( + list( + agency = data.frame(), + routes = data.frame(), + trips = data.frame(shape_id = character(0)), + stops = data.frame(), + stop_times = data.frame(trip_id = character(0), arrival_time = character(0)), + shapes = data.frame() + ), + class = c("tidygtfs", "gtfs", "list") + ) + + testthat::with_mocked_bindings( + GET = function(url, config, ...) { + captured_url <<- url + captured_headers <<- config$headers + structure(list(status_code = 200), class = "response") + }, + stop_for_status = function(res) { + NULL + }, + .package = "httr", + code = { + testthat::with_mocked_bindings( + read_gtfs = function(path, ...) { + sample_gtfs + }, + .package = "tidytransit", + code = { + gtfs <- GTFShift::load_feed(URL, headers = headers) + expect_s3_class(gtfs, "tidygtfs") + } + ) + } + ) + + expect_equal(captured_url, URL) + expect_equal(captured_headers, headers) +}) diff --git a/tests/testthat/test-multiline_to_sorted_linestring.R b/tests/testthat/test-multiline_to_sorted_linestring.R new file mode 100644 index 00000000..5302141e --- /dev/null +++ b/tests/testthat/test-multiline_to_sorted_linestring.R @@ -0,0 +1,150 @@ +library(testthat) +library(sf) + +test_that("multiline_to_sorted_linestring sorts multilinestring into linestring", { + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE), + matrix(c(1, 0, 2, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, metric_crs = 3857) + expect_s3_class(res, "sfc") + expect_equal(st_geometry_type(res)[1], factor("LINESTRING", levels = levels(st_geometry_type(res)))) +}) + +test_that("multiline_to_sorted_linestring emits warning when default metric_crs is used", { + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE), + matrix(c(1, 0, 2, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + + expect_warning( + GTFShift::multiline_to_sorted_linestring(mls_sf), + "Using default metric_crs \\(EPSG:3857\\)" + ) +}) + +test_that("multiline_to_sorted_linestring stops when metric_crs is invalid NA", { + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + + expect_error( + GTFShift::multiline_to_sorted_linestring(mls_sf, metric_crs = NA), + "metric_crs should be a valid CRS value" + ) +}) + +test_that("multiline_to_sorted_linestring parameter variation with guiding points", { + # Line 1: (1, 0) to (2, 0), Line 2: (0, 0) to (1, 0) + mls <- st_multilinestring(list( + matrix(c(1, 0, 2, 0), ncol = 2, byrow = TRUE), + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + + pts <- st_sfc( + st_point(c(0, 0)), + st_point(c(2, 0)), + crs = 4326 + ) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, points = pts, metric_crs = 3857) + coords <- unname(st_coordinates(res)) + + # Should start near (0,0) and end near (2,0) + expect_equal(coords[1, 1:2], c(0, 0)) + expect_equal(coords[nrow(coords), 1:2], c(2, 0)) +}) + +test_that("multiline_to_sorted_linestring discards line segments farther than current + next length", { + # Line 1: (0, 0) to (1, 0), Line 2: (100, 0) to (101, 0) (way too far, length=1, dist=99) + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE), + matrix(c(100, 0, 101, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, metric_crs = 3857) + coords <- unname(st_coordinates(res)) + + # Discards the far segment and retains only the first segment + expect_equal(nrow(coords), 2) + expect_equal(coords[1, 1:2], c(0, 0)) + expect_equal(coords[2, 1:2], c(1, 0)) +}) + +test_that("multiline_to_sorted_linestring orient start line when start_point is closer to remaining lines", { + mls <- st_multilinestring(list( + matrix(c(1, 0, 0, 0), ncol = 2, byrow = TRUE), + matrix(c(1, 0, 2, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + pts <- st_sfc(st_point(c(0, 0)), crs = 4326) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, points = pts, metric_crs = 3857) + coords <- unname(st_coordinates(res)) + expect_equal(coords[1, 1:2], c(0, 0)) + expect_equal(coords[nrow(coords), 1:2], c(2, 0)) +}) + +test_that("multiline_to_sorted_linestring orient start line with second_point tie break", { + mls <- st_multilinestring(list( + matrix(c(0, 0, 2, 0), ncol = 2, byrow = TRUE), + matrix(c(-1, 0, 0, 0), ncol = 2, byrow = TRUE), + matrix(c(2, 0, 3, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + pts <- st_sfc(st_point(c(1, 0)), st_point(c(0, 0)), crs = 4326) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, points = pts, metric_crs = 3857) + coords <- unname(st_coordinates(res)) + expect_equal(coords[1, 1:2], c(2, 0)) +}) + +test_that("multiline_to_sorted_linestring excludes identical duplicate remaining segments", { + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE), + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + pts <- st_sfc(st_point(c(0, 0)), crs = 4326) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, points = pts, metric_crs = 3857) + coords <- unname(st_coordinates(res)) + expect_equal(nrow(coords), 2) +}) + +test_that("multiline_to_sorted_linestring tie-breaks candidate selection using next_point proximity", { + # Line 1: (0, 0) to (1, 0) + # Candidate A: (1, 0) to (1, 1) + # Candidate B: (1, 0) to (1, -2) + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE), + matrix(c(1, 0, 1, -2), ncol = 2, byrow = TRUE), + matrix(c(1, 0, 1, 1), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + pts <- st_sfc(st_point(c(0, 0)), st_point(c(1, 1)), crs = 4326) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, points = pts, metric_crs = 3857) + expect_s3_class(res, "sfc") + coords <- unname(st_coordinates(res)) + expect_gte(nrow(coords), 3) +}) + +test_that("multiline_to_sorted_linestring handles circular ring line segment", { + # Line 1: (0, 0) to (1, 0) + # Line 2 (Circular ring): (1, 0) -> (2, 1) -> (2, -1) -> (1, 0) + mls <- st_multilinestring(list( + matrix(c(0, 0, 1, 0), ncol = 2, byrow = TRUE), + matrix(c(1, 0, 2, 1, 2, -1, 1, 0), ncol = 2, byrow = TRUE) + )) + mls_sf <- st_sf(geometry = st_sfc(mls, crs = 4326)) + + res <- GTFShift::multiline_to_sorted_linestring(mls_sf, metric_crs = 3857) + expect_s3_class(res, "sfc") +}) diff --git a/tests/testthat/test-network_overline.R b/tests/testthat/test-network_overline.R new file mode 100644 index 00000000..9d5bf859 --- /dev/null +++ b/tests/testthat/test-network_overline.R @@ -0,0 +1,107 @@ +library(testthat) +library(sf) + +test_that("network_overline aggregates lines onto target network", { + target_net <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + lines_sf <- st_sf( + frequency = c(5, 10), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + ) + + suppressWarnings({ # stplanr will warn "rsgeo not installed, using lwgeom" + res <- GTFShift::network_overline( + target_network = target_net, + lines = lines_sf, + attr = "frequency", + target_network_split = NA, + metric_crs = 3857 + ) + }) + + expect_s3_class(res, "sf") + expect_contains(names(res), "frequency") + expect_equal(res$frequency, sum(lines_sf$frequency)) # Expecting the sum of frequencies + }) + +test_that("network_overline raises warning when metric_crs is default", { + target_net <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + lines_sf <- st_sf( + frequency = 5, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + + expect_warning( + GTFShift::network_overline( + target_network = target_net, + lines = lines_sf, + attr = "frequency", + target_network_split = NA + ), + "Using default metric_crs" + ) +}) + +test_that("network_overline stops on invalid metric_crs", { + target_net <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + lines_sf <- st_sf( + frequency = 5, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + + expect_error( + GTFShift::network_overline( + target_network = target_net, + lines = lines_sf, + attr = "frequency", + metric_crs = NA + ), + "metric_crs should be a valid CRS value" + ) +}) + +test_that("network_overline handles parameter variations (target_network_split, fun, join_dist)", { + target_net <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 200, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + lines_sf <- st_sf( + frequency = c(10, 20), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 200, 0), ncol = 2, byrow = TRUE)), # original line at y = 0 + st_linestring(matrix(c(0, 5, 50, 5), ncol = 2, byrow = TRUE)), # parallel line offset by +5m at y = 5 + crs = 3857 + ) + ) + + + # Test with target_network_split = 50 and fun = max + suppressWarnings({ # stplanr will warn "rsgeo not installed, using lwgeom" + res_max <- GTFShift::network_overline( + target_network = target_net, + lines = lines_sf, + attr = "frequency", + target_network_split = 50, + fun = max, + join_dist = 15, + metric_crs = 3857 + ) + }) + + expect_s3_class(res_max, "sf") + expect_contains(names(res_max), "frequency") + expect_equal(nrow(res_max), 4) # Expecting 4 segments after splitting + expect_contains(res_max$frequency, c(10, 20)) +}) diff --git a/tests/testthat/test-osm_utils.R b/tests/testthat/test-osm_utils.R new file mode 100644 index 00000000..c1f37e9d --- /dev/null +++ b/tests/testthat/test-osm_utils.R @@ -0,0 +1,204 @@ +library(testthat) +library(sf) + +test_that("filter_osm_bus_lanes correctly filters bus lane features", { + road_osm <- st_sf( + osm_id = c("1", "2", "3"), + psv = c("designated", "no", "no"), + `lanes:bus` = c(NA, "0", "1"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), + st_linestring(matrix(c(1, 1, 2, 2), ncol = 2)), + st_linestring(matrix(c(2, 2, 3, 3), ncol = 2)), + crs = 4326 + ) + ) + + filtered <- GTFShift:::filter_osm_bus_lanes(road_osm) + expect_equal(nrow(filtered), 2) + expect_equal(filtered$osm_id, c("1", "3")) +}) + +setup_mock_xml <- function(env = parent.frame()) { + mock_xml <- ' + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ' + + mock_xml_file <- withr::local_tempfile(fileext = ".xml", .local_envir = env) + writeLines(mock_xml, mock_xml_file) + return(mock_xml_file) +} + +make_mock_bg_job <- function() { + list( + is_alive = function() FALSE, + get_result = function() NULL + ) +} + +make_mock_pb <- function() { + list( + tick = function(...) invisible(NULL), + update = function(...) invisible(NULL) + ) +} + +test_that("get_osm_relations parses relations with regex feature operator ~", { + mock_xml_file <- setup_mock_xml() + on.exit(unlink(mock_xml_file), add = TRUE) + + testthat::with_mocked_bindings( + r_bg = function(...) make_mock_bg_job(), + .package = "callr", + code = { + testthat::with_mocked_bindings( + show_content = function(...) mock_xml_file, + .package = "rosmium", + code = { + res_regex <- GTFShift:::get_osm_relations( + osm_file = "dummy.pbf", + q = list(features = '["ref"~"701"]'), + pb = make_mock_pb(), + osm_route_type = "bus" + ) + + expect_s3_class(res_regex, "data.frame") + expect_equal(nrow(res_regex), 4) # 2 members from rel 100, 2 members from rel 700 + expect_equal(unique(res_regex$relation_osm_id), c("100", "700")) + } + ) + } + ) +}) + +test_that("get_osm_relations parses relations with exact equality feature operator =", { + mock_xml_file <- setup_mock_xml() + on.exit(unlink(mock_xml_file), add = TRUE) + + testthat::with_mocked_bindings( + r_bg = function(...) make_mock_bg_job(), + .package = "callr", + code = { + testthat::with_mocked_bindings( + show_content = function(...) mock_xml_file, + .package = "rosmium", + code = { + res_exact <- GTFShift:::get_osm_relations( + osm_file = "dummy.pbf", + q = list(features = '["ref"="701exact"]'), + pb = make_mock_pb(), + osm_route_type = "bus" + ) + + expect_s3_class(res_exact, "data.frame") + expect_equal(nrow(res_exact), 2) + expect_equal(unique(res_exact$relation_osm_id), "700") + } + ) + } + ) +}) + +test_that("get_osm_relations returns empty data frame when no features match", { + mock_xml_file <- setup_mock_xml() + on.exit(unlink(mock_xml_file), add = TRUE) + + testthat::with_mocked_bindings( + r_bg = function(...) make_mock_bg_job(), + .package = "callr", + code = { + testthat::with_mocked_bindings( + show_content = function(...) mock_xml_file, + .package = "rosmium", + code = { + res_none <- GTFShift:::get_osm_relations( + osm_file = "dummy.pbf", + q = list(features = '["ref"="nonexistent"]'), + pb = make_mock_pb(), + osm_route_type = "bus" + ) + + expect_equal(nrow(res_none), 0) + } + ) + } + ) +}) + +test_that("get_osm_relations correctly forwards custom osm_route_type parameter", { + mock_xml_file <- setup_mock_xml() + on.exit(unlink(mock_xml_file), add = TRUE) + + passed_filter <- NULL + + testthat::with_mocked_bindings( + r_bg = function(func, args, ...) { + # Capture filter string passed to rosmium::tags_filter in r_bg call + passed_filter <<- args[[3]] + make_mock_bg_job() + }, + .package = "callr", + code = { + testthat::with_mocked_bindings( + show_content = function(...) mock_xml_file, + .package = "rosmium", + code = { + res <- GTFShift:::get_osm_relations( + osm_file = "dummy.pbf", + q = list(features = '["ref"~"701"]'), + pb = make_mock_pb(), + osm_route_type = "train" + ) + + expect_equal(passed_filter, "train") + expect_s3_class(res, "data.frame") + expect_equal(nrow(res), 4) + } + ) + } + ) +}) + + + + + diff --git a/tests/testthat/test-prioritise_lanes.R b/tests/testthat/test-prioritise_lanes.R new file mode 100644 index 00000000..0817d76e --- /dev/null +++ b/tests/testthat/test-prioritise_lanes.R @@ -0,0 +1,94 @@ +library(testthat) +library(sf) + +test_that("prioritise_lanes analyzes lane prioritisation with mocked dependencies", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + mock_way_freq <- st_sf( + way_osm_id = c("1001", "1002"), + hour = c(8, 8), + frequency = c(12, 15), + routes = I(list(c("R1"), c("R2"))), + shapes = I(list(c("S1"), c("S2"))), + lanes = c("2", "4"), + oneway = c("yes", "no"), + psv = c(NA, "designated"), + `parking:lane:both` = c("parallel", "no"), + `parking:lane:left` = c(NA, "diagonal"), + `parking:lane:right` = c(NA, "no"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 200, 0), ncol = 2, byrow = TRUE)), + crs = 4326 + ) + ) + + testthat::with_mocked_bindings( + get_way_frequency_hourly = function(...) { + mock_way_freq + }, + .package = "GTFShift", + code = { + res <- GTFShift::prioritise_lanes(gtfs, q = NA, date = ref_date) + expect_s3_class(res, "sf") + expect_equal(nrow(res), 2) + + # Default keep_osm_attributes = FALSE: OSM columns should not be in the output + expect_false(any(c("lanes", "oneway", "psv", "parking:lane:both") %in% names(res))) + + # Check is_bus_lane + expect_equal(res$is_bus_lane, c(FALSE, TRUE)) + + # Check n_lanes_parking + expect_equal(res$n_lanes_parking, c(2L, 1L)) + + # Check n_lanes_circulation + expect_equal(res$n_lanes_circulation, c(2, 4)) + + # Check n_directions + expect_equal(res$n_directions, c(1, 2)) + + # Check n_lanes_circulation_direction + expect_equal(res$n_lanes_circulation_direction, c(2, 2)) + } + ) +}) + +test_that("prioritise_lanes retains extra OSM attributes when keep_osm_attributes = TRUE", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + ref_date <- gtfs$calendar$start_date[1] + + mock_way_freq <- st_sf( + way_osm_id = c("1001", "1002"), + hour = c(8, 8), + frequency = c(12, 15), + routes = I(list(c("R1"), c("R2"))), + shapes = I(list(c("S1"), c("S2"))), + lanes = c("2", "4"), + oneway = c("yes", "no"), + psv = c(NA, "designated"), + `parking:lane:both` = c("parallel", "no"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 200, 0), ncol = 2, byrow = TRUE)), + crs = 4326 + ) + ) + + testthat::with_mocked_bindings( + get_way_frequency_hourly = function(...) { + mock_way_freq + }, + .package = "GTFShift", + code = { + res <- GTFShift::prioritise_lanes(gtfs, q = NA, date = ref_date, keep_osm_attributes = TRUE) + expect_s3_class(res, "sf") + expect_contains(names(res), c("lanes", "oneway", "psv", "parking:lane:both")) + } + ) +}) diff --git a/tests/testthat/test-project_points_along_geometry.R b/tests/testthat/test-project_points_along_geometry.R new file mode 100644 index 00000000..07f36cfa --- /dev/null +++ b/tests/testthat/test-project_points_along_geometry.R @@ -0,0 +1,106 @@ +library(testthat) +library(sf) + +test_that("project_points_along_geometry computes projection and cumulative distance", { + line <- st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + res <- GTFShift::project_points_along_geometry(line, pts, geometry_sample_meters = 5, metric_crs = 3857) + expect_equal(nrow(res), 1) + expect_contains(names(res), c("distance_to_closest_on_geometry", "distance_along_geometry", "distance_along_geometry_reversed")) +}) + +test_that("project_points_along_geometry emits warning when default metric_crs is used", { + line <- st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + expect_warning( + GTFShift::project_points_along_geometry(line, pts), + "Using default metric_crs \\(EPSG:3857\\)" + ) +}) + +test_that("project_points_along_geometry stops when metric_crs is invalid NA", { + line <- st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + expect_error( + GTFShift::project_points_along_geometry(line, pts, metric_crs = NA), + "metric_crs should be a valid CRS value" + ) +}) + +test_that("project_points_along_geometry stops when geometry is not sf or sfc", { + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + expect_error( + GTFShift::project_points_along_geometry("not_a_geometry", pts, metric_crs = 3857), + "geometry must be an sf object or sfc geometry" + ) +}) + +test_that("project_points_along_geometry stops when points is not sf or sfc", { + line <- st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + + expect_error( + GTFShift::project_points_along_geometry(line, "not_points", metric_crs = 3857), + "points must be an sf object or sfc geometry" + ) +}) + +test_that("project_points_along_geometry stops when geometry does not have exactly one feature", { + line_multi <- st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(100, 0, 200, 0), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + expect_error( + GTFShift::project_points_along_geometry(line_multi, pts, metric_crs = 3857), + "geometry must contain exactly one feature" + ) +}) + +test_that("project_points_along_geometry handles empty points input", { + line <- st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 3857) + pts_empty <- st_sfc(crs = 3857) + + res <- GTFShift::project_points_along_geometry(line, pts_empty, metric_crs = 3857) + expect_equal(nrow(res), 0) + expect_contains(names(res), c("distance_to_closest_on_geometry", "distance_along_geometry", "distance_along_geometry_reversed")) +}) + +test_that("project_points_along_geometry stops when geometry is not LINESTRING or MULTILINESTRING", { + point_geom <- st_sfc(st_point(c(50, 50)), crs = 3857) + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + expect_error( + GTFShift::project_points_along_geometry(point_geom, pts, metric_crs = 3857), + "geometry must be LINESTRING or MULTILINESTRING" + ) +}) + +test_that("project_points_along_geometry stops when geometry or points CRS is NA", { + line_nocrs <- st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = NA_crs_) + pts <- st_sfc(st_point(c(20, 10)), crs = 3857) + + expect_error( + GTFShift::project_points_along_geometry(line_nocrs, pts, metric_crs = 3857), + "geometry and points must have a valid CRS to use metric_crs" + ) +}) + +test_that("project_points_along_geometry works with MULTILINESTRING and sf inputs", { + mls <- st_multilinestring(list( + matrix(c(0, 0, 50, 0), ncol = 2, byrow = TRUE), + matrix(c(50, 0, 100, 0), ncol = 2, byrow = TRUE) + )) + line_sf <- st_sf(geometry = st_sfc(mls, crs = 3857)) + pts_sf <- st_sf(geometry = st_sfc(st_point(c(25, 5)), st_point(c(75, -5)), crs = 3857)) + + res <- GTFShift::project_points_along_geometry(line_sf, pts_sf, geometry_sample_meters = 100, metric_crs = 3857) + expect_equal(nrow(res), 2) + expect_s3_class(res$closest_on_geometry, "sfc_POINT") + expect_equal(st_crs(res$closest_on_geometry), st_crs(3857)) +}) diff --git a/tests/testthat/test-query_mobilitydatabase.R b/tests/testthat/test-query_mobilitydatabase.R new file mode 100644 index 00000000..c879f12a --- /dev/null +++ b/tests/testthat/test-query_mobilitydatabase.R @@ -0,0 +1,223 @@ +library(testthat) + +create_mock_response <- function(status_code = 200) { + structure( + list( + status_code = status_code, + content = raw(0), + url = "https://api.mobilitydatabase.org/v1/gtfs_feeds" + ), + class = "response" + ) +} + +test_that("query_mobilitydatabase throws error if no token is provided", { + expect_error( + GTFShift::query_mobilitydatabase(), + "No token provided!" + ) +}) + +test_that("query_mobilitydatabase successfully queries with access token", { + mock_feeds <- list( + list( + id = "feed_1", + data_type = "gtfs", + created_at = "2023-01-01T00:00:00Z", + provider = "Test Provider", + feed_contact_email = "test@example.com", + status = "active", + official = TRUE, + official_updated_at = "2023-01-01T00:00:00Z", + feed_name = "Test Feed", + note = NULL, + source_info = list( + producer_url = "https://example.com/gtfs.zip", + license_url = "https://example.com/license" + ), + locations = list( + list( + country_code = "PT", + country = "Portugal", + subdivision_name = "Lisboa", + municipality = "Lisbon" + ) + ), + latest_dataset = list( + id = "dataset_1", + hosted_url = "https://example.com/dataset_1.zip", + bounding_box = list( + minimum_latitude = 38.7, + maximum_latitude = 38.8, + minimum_longitude = -9.2, + maximum_longitude = -9.1 + ), + downloaded_at = "2023-01-02T00:00:00Z", + service_date_range_start = "2023-01-01", + service_date_range_end = "2023-12-31", + agency_timezone = "Europe/Lisbon", + validation_report = list( + total_error = 0, + total_warning = 2 + ) + ) + ) + ) + + mock_resp <- create_mock_response(status_code = 200) + + testthat::with_mocked_bindings( + GET = function(url, query, ...) { + expect_equal(url, "https://api.mobilitydatabase.org/v1/gtfs_feeds") + expect_equal(query$country_code, "PT") + expect_equal(query$bounding_filter_method, "partially_enclosed") + expect_equal(query$limit, 10) + expect_equal(query$offset, 0) + return(mock_resp) + }, + .package = "httr", + code = { + testthat::with_mocked_bindings( + content = function(x, ...) mock_feeds, + http_error = function(x) FALSE, + .package = "GTFShift", + code = { + df <- GTFShift::query_mobilitydatabase(access_token = "mock_access_token", country_code = "PT") + expect_s3_class(df, "data.frame") + expect_equal(nrow(df), 1) + expect_equal(df$id[1], "feed_1") + expect_equal(df$provider[1], "Test Provider") + expect_equal(df$country_code[1], "PT") + expect_equal(df$latest_dataset_id[1], "dataset_1") + expect_equal(df$validation_errors[1], 0) + expect_equal(df$validation_warnings[1], 2) + } + ) + } + ) +}) + +test_that("query_mobilitydatabase fetches access token using refresh token when access_token is missing", { + mock_resp_post <- create_mock_response(status_code = 200) + mock_resp_get <- create_mock_response(status_code = 200) + + post_called <- FALSE + get_called <- FALSE + + testthat::with_mocked_bindings( + POST = function(url, body, ...) { + post_called <<- TRUE + expect_equal(url, "https://api.mobilitydatabase.org/v1/tokens") + expect_true(grepl("mock_refresh_token", body)) + return(mock_resp_post) + }, + GET = function(url, query, ...) { + get_called <<- TRUE + expect_equal(url, "https://api.mobilitydatabase.org/v1/gtfs_feeds") + return(mock_resp_get) + }, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + content = function(x, ...) { + if (!get_called) { + return(list(access_token = "new_access_token_from_refresh")) + } else { + return(list( + list( + id = "feed_2", + provider = "Provider 2", + status = "active" + ) + )) + } + }, + http_error = function(x) FALSE, + .package = "GTFShift", + code = { + df <- GTFShift::query_mobilitydatabase(refresh_token = "mock_refresh_token") + expect_true(post_called) + expect_true(get_called) + expect_equal(nrow(df), 1) + expect_equal(df$id[1], "feed_2") + } + ) + } + ) +}) + +test_that("query_mobilitydatabase handles HTTP errors when getting feeds", { + mock_resp <- create_mock_response(status_code = 401) + + testthat::with_mocked_bindings( + GET = function(url, ...) mock_resp, + .package = "httr", + code = { + testthat::with_mocked_bindings( + content = function(x, ...) list(detail = "Unauthorized"), + http_error = function(x) TRUE, + http_status = function(x) "Client error: (401) Unauthorized", + .package = "GTFShift", + code = { + expect_error( + GTFShift::query_mobilitydatabase(access_token = "invalid_token"), + "Mobility database bad response: Client error: \\(401\\) Unauthorized" + ) + } + ) + } + ) +}) + +test_that("query_mobilitydatabase handles HTTP errors during refresh token exchange", { + mock_resp_post <- create_mock_response(status_code = 400) + + testthat::with_mocked_bindings( + POST = function(url, ...) mock_resp_post, + .package = "httr", + code = { + testthat::with_mocked_bindings( + content = function(x, ...) list(detail = "Invalid refresh token"), + http_error = function(x) TRUE, + http_status = function(x) "Client error: (400) Bad Request", + .package = "GTFShift", + code = { + expect_error( + GTFShift::query_mobilitydatabase(refresh_token = "bad_refresh_token"), + "Mobility database bad response: Client error: \\(400\\) Bad Request" + ) + } + ) + } + ) +}) + +test_that("query_mobilitydatabase formats bbox parameter correctly", { + mock_resp <- create_mock_response(status_code = 200) + + bbox_obj <- structure( + list(ymin = list(38.7), ymax = list(38.8), xmin = list(-9.2), xmax = list(-9.1)), + class = "bbox" + ) + + testthat::with_mocked_bindings( + GET = function(url, query, ...) { + expect_equal(query$dataset_latitudes, "38.700000,38.800000") + expect_equal(query$dataset_longitudes, "-9.200000,-9.100000") + return(mock_resp) + }, + .package = "httr", + code = { + testthat::with_mocked_bindings( + content = function(x, ...) list(), + http_error = function(x) FALSE, + .package = "GTFShift", + code = { + df <- GTFShift::query_mobilitydatabase(access_token = "token", bbox = bbox_obj) + expect_equal(nrow(df), 0) + } + ) + } + ) +}) + diff --git a/tests/testthat/test-query_osm_bus_lanes.R b/tests/testthat/test-query_osm_bus_lanes.R new file mode 100644 index 00000000..4e6e143f --- /dev/null +++ b/tests/testthat/test-query_osm_bus_lanes.R @@ -0,0 +1,62 @@ +library(testthat) +library(sf) + +test_that("osm_bus_lanes queries and filters bus lanes using mocked osmextract", { + mock_lines <- st_sf( + osm_id = c("1", "2"), + psv = c("designated", "no"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), + st_linestring(matrix(c(1, 1, 2, 2), ncol = 2)), + crs = 4326 + ) + ) + + testthat::with_mocked_bindings( + oe_read = function(...) { + mock_lines + }, + oe_get_keys = function(...) { + c("psv") + }, + .package = "osmextract", + code = { + bbox <- st_bbox(st_sfc(st_point(c(0, 0)), crs = 4326)) + res <- GTFShift::osm_bus_lanes(bbox, osm_file = "dummy.pbf") + expect_s3_class(res, "sf") + expect_equal(nrow(res), 1) + expect_equal(res[["osm:id"]][1], "1") + expect_false("2" %in% res[["osm:id"]]) + } + ) +}) + +test_that("osm_bus_lanes queries bus lanes when osm_file = NULL using mocked osmdata", { + mock_lines <- st_sf( + osm_id = c("1", "2"), + psv = c("designated", "no"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), + st_linestring(matrix(c(1, 1, 2, 2), ncol = 2)), + crs = 4326 + ) + ) + + mock_osmdata <- list(osm_lines = mock_lines) + + testthat::with_mocked_bindings( + opq = function(...) "mock_opq", + add_osm_feature = function(...) "mock_opq", + osmdata_sf = function(...) mock_osmdata, + osm_poly2line = function(...) mock_osmdata, + .package = "GTFShift", + code = { + bbox <- st_bbox(st_sfc(st_point(c(0, 0)), crs = 4326)) + res <- GTFShift::osm_bus_lanes(bbox, osm_file = NULL) + expect_s3_class(res, "sf") + expect_equal(nrow(res), 1) + expect_equal(res$osm_id[1], "1") + expect_false("2" %in% res$osm_id) + } + ) +}) diff --git a/tests/testthat/test-query_osm_centerlines.R b/tests/testthat/test-query_osm_centerlines.R new file mode 100644 index 00000000..e0829036 --- /dev/null +++ b/tests/testthat/test-query_osm_centerlines.R @@ -0,0 +1,113 @@ +library(testthat) +library(sf) + +test_that("osm_centerlines reads generated geopkg from python call with mocked reticulate", { + mock_line <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), crs = 4326) + ) + + get_centerline_called <- FALSE + + testthat::with_mocked_bindings( + virtualenv_create = function(...) "mock_venv", + use_virtualenv = function(...) TRUE, + source_python = function(file, envir = parent.frame(), ...) { + envir$get_centerline <- function(...) { + get_centerline_called <<- TRUE + TRUE + } + TRUE + }, + py_install = function(...) TRUE, + .package = "reticulate", + code = { + testthat::with_mocked_bindings( + st_read = function(dsn, ...) mock_line, + .package = "sf", + code = { + res <- GTFShift::osm_centerlines(bbox = NULL, place = "Porto", venv = "mock_env") + expect_true(get_centerline_called) + expect_s3_class(res, "sf") + } + ) + } + ) +}) + +test_that("osm_centerlines creates virtualenv when venv parameter is omitted/NA", { + mock_line <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), crs = 4326) + ) + + virtualenv_create_called <- FALSE + get_centerline_called <- FALSE + + testthat::with_mocked_bindings( + virtualenv_create = function(...) { + virtualenv_create_called <<- TRUE + "mock_created_venv" + }, + use_virtualenv = function(...) TRUE, + source_python = function(file, envir = parent.frame(), ...) { + envir$get_centerline <- function(...) { + get_centerline_called <<- TRUE + TRUE + } + TRUE + }, + py_install = function(...) TRUE, + .package = "reticulate", + code = { + testthat::with_mocked_bindings( + st_read = function(dsn, ...) mock_line, + .package = "sf", + code = { + res <- GTFShift::osm_centerlines(bbox = NULL, place = "Porto") + expect_true(virtualenv_create_called) + expect_true(get_centerline_called) + expect_s3_class(res, "sf") + } + ) + } + ) +}) + +test_that("osm_centerlines passes osm_file parameter to python call", { + mock_line <- st_sf( + id = 1, + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1, 1), ncol = 2)), crs = 4326) + ) + + received_osm_file <- NULL + + testthat::with_mocked_bindings( + virtualenv_create = function(...) "mock_venv", + use_virtualenv = function(...) TRUE, + source_python = function(file, envir = parent.frame(), ...) { + envir$get_centerline <- function(bbox, study_area, use_buildings, output_path, osm_file = NULL) { + received_osm_file <<- osm_file + TRUE + } + TRUE + }, + py_install = function(...) TRUE, + .package = "reticulate", + code = { + testthat::with_mocked_bindings( + st_read = function(dsn, ...) mock_line, + .package = "sf", + code = { + res <- osm_centerlines(osm_file = "path/to/region.osm.pbf", venv = "mock_env") + expect_equal(received_osm_file, "path/to/region.osm.pbf") + expect_s3_class(res, "sf") + } + ) + } + ) +}) + + + + diff --git a/tests/testthat/test-query_osm_shapes_match_routes.R b/tests/testthat/test-query_osm_shapes_match_routes.R new file mode 100644 index 00000000..dc59d1dd --- /dev/null +++ b/tests/testthat/test-query_osm_shapes_match_routes.R @@ -0,0 +1,669 @@ +library(testthat) +library(sf) + +# Helper fixture setup for osm_shapes_match_routes +setup_match_fixtures <- function(gtfs) { + target_route_id <- gtfs$routes$route_id[1] + target_route <- gtfs$routes$route_short_name[1] + target_shape_id <- gtfs$trips$shape_id[gtfs$trips$route_id == target_route_id][1] + + mock_rel_df <- data.frame( + relation_osm_id = "rel_1", + type = c("way", "node", "node"), + osm_id = c("w1", "n1", "n2"), + role = c("forward", "stop_entry_only", "stop_exit_only"), + ref = target_route, + name = paste("Line", target_route), + gtfs_shape_id = NA_character_, + gtfs_route_id = NA_character_, + roundtrip = "no", + stringsAsFactors = FALSE, + check.names = FALSE + ) + + mock_ways <- st_sf( + osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + mock_stops <- st_sf( + osm_id = c("n1", "n2"), + public_transport = c("stop_position", "stop_position"), + geometry = st_sfc(st_point(c(-8.6, 41.1)), st_point(c(-8.61, 41.11)), crs = 4326) + ) + + list( + target_route_id = target_route_id, + target_route = target_route, + target_shape_id = target_shape_id, + rel_df = mock_rel_df, + ways = mock_ways, + stops = mock_stops + ) +} + +test_that("osm_shapes_match_routes validates input parameters and throws errors", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + # Invalid gtfs_match + expect_error( + GTFShift::osm_shapes_match_routes(gtfs, q = NA, gtfs_match = "invalid_col"), + "gtfs_match should be one of" + ) + + # Invalid osm_match + expect_error( + GTFShift::osm_shapes_match_routes(gtfs, q = NA, osm_match = "invalid_col"), + "osm_match should be one of" + ) + + # Invalid metric_crs + expect_error( + GTFShift::osm_shapes_match_routes(gtfs, q = NA, metric_crs = "invalid_crs_string"), + ) + + # Invalid metric_crs + expect_error( + GTFShift::osm_shapes_match_routes(gtfs, q = NA, metric_crs = NA) + ) +}) + +test_that("osm_shapes_match_routes executes matching flow with osm_file provided", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf", + metric_crs = 3857 + )) + + expect_s3_class(res, "sf") + expect_contains(names(res), c("route_id", "shape_id", "osm_id", "distance_diff", "points_diff", "stops_diff", "geometry")) + expect_equal(res$osm_id[1], "rel_1") + expect_equal(res$shape_id[1], fx$target_shape_id) + + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("Found \\d+ GTFS shapes and \\d+ stops", log_lines))) + expect_true(any(grepl("Found \\d+ OSM route relations and \\d+ stops/platforms", log_lines))) + expect_true(any(grepl("Associated \\d+ shapes", log_lines))) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes executes matching flow when osm_file is NULL (Overpass API path)", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + mock_multilines <- st_sf( + osm_id = "rel_1", + ref = fx$target_route, + name = paste("Line", fx$target_route), + geometry = st_sfc(st_multilinestring(list(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2))), crs = 4326) + ) + + mock_osm_data <- list( + osm_multilines = mock_multilines, + osm_points = fx$stops + ) + + mock_bg_job_xml <- list(is_alive = function() FALSE, get_result = function() NULL) + mock_bg_job_sf <- list(is_alive = function() FALSE, get_result = function() mock_osm_data) + mock_bg_job_points <- list(is_alive = function() FALSE, get_result = function() fx$stops) + mock_bg_job_rel <- list(is_alive = function() FALSE, get_result = function() fx$rel_df) + + r_bg_call_count <- 0 + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + testthat::with_mocked_bindings( + r_bg = function(...) { + r_bg_call_count <<- r_bg_call_count + 1 + if (r_bg_call_count == 1) { + return(mock_bg_job_xml) + } else if (r_bg_call_count == 2) { + return(mock_bg_job_sf) + } else if (r_bg_call_count == 3) { + return(mock_bg_job_points) + } else { + return(mock_bg_job_rel) + } + }, + .package = "callr", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = "dummy_q", + log_file = log_tmp, + osm_file = NULL, + metric_crs = 3857 + )) + + expect_s3_class(res, "sf") + expect_contains(names(res), c("route_id", "shape_id", "osm_id", "geometry")) + expect_equal(res$osm_id[1], "rel_1") + + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("Found \\d+ OSM route relations and \\d+ stops/platforms", log_lines))) + } + ) +}) + +test_that("osm_shapes_match_routes supports non-exact string matching (gtfs_osm_match_exact = FALSE)", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + fx$rel_df$ref <- paste("Route", fx$target_route, "Express") + + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + gtfs_osm_match_exact = FALSE, + osm_file = "dummy.pbf", + metric_crs = 3857 + )) + + expect_s3_class(res, "sf") + expect_gt(nrow(res), 0) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes writes logs to log_file when provided", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf", + metric_crs = 3857 + )) + + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("Running osm_shapes_match_routes", log_lines))) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes returns plain data.frame when geometry = FALSE", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + geometry = FALSE, + osm_file = "dummy.pbf", + metric_crs = 3857 + )) + + expect_false(inherits(res, "sf")) + expect_s3_class(res, "data.frame") + expect_false("geometry" %in% names(res)) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes issues warnings when routes or stops are missing or unsorted", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + mock_rel_empty <- data.frame( + relation_osm_id = "rel_1", + type = "way", + osm_id = "w1", + role = "forward", + ref = "NON_EXISTENT_REF", + name = "Unknown Route", + gtfs_shape_id = NA_character_, + gtfs_route_id = NA_character_, + roundtrip = "no", + stringsAsFactors = FALSE + ) + + mock_ways_empty <- st_sf( + osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + mock_stops <- st_sf( + osm_id = "n1", + public_transport = "stop_position", + geometry = st_sfc(st_point(c(-8.6, 41.1)), crs = 4326) + ) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_empty, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") mock_stops else mock_ways_empty + }, + .package = "osmextract", + code = { + warn_pattern <- "did not match any OSM route" + expect_warning( + GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf", + metric_crs = 3857 + ), + warn_pattern + ) + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("WARNING!", log_lines) & grepl(warn_pattern, log_lines))) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes issues warning when metric_crs is default / missing", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + warn_pattern <- "Using default metric_crs" + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- expect_warning( + GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf" + ), + warn_pattern + ) + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("WARNING!", log_lines) & grepl(warn_pattern, log_lines))) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes handles unsorted stops and osm_stop_order_relaxed parameter", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + # Unsorted relation: entry stop is at position 2 instead of position 1 + mock_rel_unsorted <- data.frame( + relation_osm_id = "rel_1", + type = c("node", "node", "way"), + osm_id = c("n2", "n1", "w1"), + role = c("stop_exit_only", "stop_entry_only", "forward"), + ref = fx$target_route, + name = paste("Line", fx$target_route), + gtfs_shape_id = NA_character_, + gtfs_route_id = NA_character_, + roundtrip = "no", + stringsAsFactors = FALSE, + check.names = FALSE + ) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + # With osm_stop_order_relaxed = FALSE (default), unsorted stops trigger warning and result in no match + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_unsorted, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + warn_pattern <- "entry/exit stops not respecting the right order" + expect_warning( + GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf", + metric_crs = 3857, + osm_stop_order_relaxed = FALSE + ), + warn_pattern + ) + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("WARNING!", log_lines) & grepl(warn_pattern, log_lines))) + + # With osm_stop_order_relaxed = TRUE, relation is matched despite unsorted stops + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + osm_file = "dummy.pbf", + metric_crs = 3857, + osm_stop_order_relaxed = TRUE + )) + expect_s3_class(res, "sf") + expect_equal(nrow(res), 1) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes returns empty result when !osm_stop_order_relaxed and unsorted stops", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + mock_rel_unsorted <- data.frame( + relation_osm_id = "rel_1", + type = c("node", "node", "way"), + osm_id = c("n2", "n1", "w1"), + role = c("stop_exit_only", "stop_entry_only", "forward"), + ref = fx$target_route, + name = paste("Line", fx$target_route), + gtfs_shape_id = NA_character_, + gtfs_route_id = NA_character_, + roundtrip = "no", + stringsAsFactors = FALSE, + check.names = FALSE + ) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_unsorted, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + osm_file = "dummy.pbf", + metric_crs = 3857, + osm_stop_order_relaxed = FALSE + )) + expect_s3_class(res, "sf") + expect_equal(nrow(res), 0) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes handles empty gtfs_route_name or error in stop evaluation (warn_osm_stops_missing)", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + mock_rel_bad_stops <- data.frame( + relation_osm_id = "rel_1", + type = c("way", "node", "node"), + osm_id = c("w1", "n1", "n2"), + role = c("forward", "stop_entry_only", "stop_exit_only"), + ref = fx$target_route, + name = paste("Line", fx$target_route), + gtfs_shape_id = NA_character_, + gtfs_route_id = NA_character_, + roundtrip = "no", + stringsAsFactors = FALSE, + check.names = FALSE + ) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_bad_stops, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + testthat::with_mocked_bindings( + drop_units = function(x) { + if (inherits(x, "sgbp") || is.numeric(x) || inherits(x, "units")) { + stop("Simulated stop distance calculation error") + } + x + }, + .package = "units", + code = { + warn_pattern <- "There were \\d+ error\\(s\\) during the algorithm execution" + expect_warning( + GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf", + metric_crs = 3857 + ), + warn_pattern + ) + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("WARNING!", log_lines) & grepl("error\\(s\\) during the algorithm execution", log_lines))) + } + ) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes supports parallel execution (num_cores > 1)", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + osm_file = "dummy.pbf", + metric_crs = 3857, + num_cores = 2 + )) + + expect_s3_class(res, "sf") + expect_gt(nrow(res), 0) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes prints warning messages to console when errors occur", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + mock_rel_empty <- data.frame( + relation_osm_id = "rel_1", + type = "way", + osm_id = "w1", + role = "forward", + ref = "NON_EXISTENT_REF", + name = "Unknown Route", + gtfs_shape_id = NA_character_, + gtfs_route_id = NA_character_, + roundtrip = "no", + stringsAsFactors = FALSE + ) + + mock_ways_empty <- st_sf( + osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + mock_stops <- st_sf( + osm_id = "n1", + public_transport = "stop_position", + geometry = st_sfc(st_point(c(-8.6, 41.1)), crs = 4326) + ) + + log_tmp <- withr::local_tempfile(fileext = ".log") + on.exit(unlink(log_tmp), add = TRUE) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_empty, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") mock_stops else mock_ways_empty + }, + .package = "osmextract", + code = { + warn_pattern <- "There were \\d+ error\\(s\\) during the algorithm execution" + expect_warning( + GTFShift::osm_shapes_match_routes( + gtfs = gtfs, + q = NA, + log_file = log_tmp, + osm_file = "dummy.pbf", + metric_crs = 3857 + ), + warn_pattern + ) + expect_true(file.exists(log_tmp)) + log_lines <- readLines(log_tmp) + expect_true(any(grepl("WARNING!", log_lines) & grepl("error\\(s\\) during the algorithm execution", log_lines))) + } + ) + } + ) +}) + +test_that("osm_shapes_match_routes handles GTFS route with no trips or shapes (nrow(gtfs_route_name) == 0)", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + fx <- setup_match_fixtures(gtfs) + + # Modify GTFS trips to remove all trips for the target route, resulting in nrow(gtfs_route_name) == 0 + gtfs_no_trips <- gtfs + gtfs_no_trips$trips <- gtfs_no_trips$trips[0, ] + + testthat::with_mocked_bindings( + get_osm_relations = function(...) fx$rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, layer = "lines", ...) { + if (!missing(layer) && layer == "points") fx$stops else fx$ways + }, + .package = "osmextract", + code = { + res <- suppressWarnings(GTFShift::osm_shapes_match_routes( + gtfs = gtfs_no_trips, + q = NA, + osm_file = "dummy.pbf", + metric_crs = 3857 + )) + expect_equal(nrow(res), 0) + } + ) + } + ) +}) + diff --git a/tests/testthat/test-query_osm_shapes_to_routes.R b/tests/testthat/test-query_osm_shapes_to_routes.R new file mode 100644 index 00000000..96f6205c --- /dev/null +++ b/tests/testthat/test-query_osm_shapes_to_routes.R @@ -0,0 +1,240 @@ +library(testthat) +library(sf) + +test_that("osm_shapes_to_routes matches shapes by gtfs:shape_id using mocks", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + + mock_rel_df <- data.frame( + relation_osm_id = "rel_1", + type = "way", + osm_id = "w1", + role = "forward", + `gtfs:shape_id` = target_shape_id, + stringsAsFactors = FALSE, + check.names = FALSE + ) + + mock_ways <- st_sf( + osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(...) mock_ways, + .package = "osmextract", + code = { + suppressWarnings({ # There will be warns about gtfs shapes not matched + res <- GTFShift::osm_shapes_to_routes(gtfs, q = NA, osm_file = "dummy.pbf") + }) + expect_s3_class(res, "sf") + expect_contains(names(res), c("shape_id", "osm_id", "geometry")) + } + ) + } + ) +}) + +test_that("osm_shapes_to_routes works when osm_file is not provided (calls Overpass API)", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + + mock_multilines <- st_sf( + osm_id = "rel_1", + `gtfs:shape_id` = target_shape_id, + geometry = st_sfc(st_multilinestring(list(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2))), crs = 4326) + ) + + mock_osm_data <- list( + osm_multilines = mock_multilines + ) + + mock_bg_job <- list( + is_alive = function() FALSE, + get_result = function() mock_osm_data + ) + + mock_bg_job_xml <- list( + is_alive = function() FALSE, + get_result = function() NULL + ) + + r_bg_call_count <- 0 + + testthat::with_mocked_bindings( + r_bg = function(...) { + r_bg_call_count <<- r_bg_call_count + 1 + if (r_bg_call_count == 1) { + return(mock_bg_job_xml) + } else { + return(mock_bg_job) + } + }, + .package = "callr", + code = { + suppressWarnings({ # There will be warns about gtfs shapes not matched + res <- GTFShift::osm_shapes_to_routes(gtfs, q = "dummy_q", osm_file = NULL) + }) + expect_s3_class(res, "sf") + expect_contains(names(res), c("shape_id", "osm_id", "geometry")) + expect_equal(nrow(res), 1) + expect_equal(res$shape_id, target_shape_id) + expect_equal(res$osm_id, "rel_1") + } + ) +}) + +test_that("osm_shapes_to_routes with ways = TRUE and osm_file provided extracts way tags", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + + mock_rel_df <- data.frame( + relation_osm_id = "rel_1", + type = "way", + osm_id = "w1", + role = "forward", + `gtfs:shape_id` = target_shape_id, + stringsAsFactors = FALSE, + check.names = FALSE + ) + + mock_ways <- st_sf( + osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + mock_extra_tags <- data.frame( + osm_id = "w1", + lanes = "2", + maxspeed = "50", + other_tags = "dummy", + stringsAsFactors = FALSE, + check.names = FALSE + ) + + testthat::with_mocked_bindings( + get_osm_relations = function(...) mock_rel_df, + .package = "GTFShift", + code = { + testthat::with_mocked_bindings( + oe_read = function(file, extra_tags = NULL, ...) { + if (is.null(extra_tags)) { + return(mock_ways) + } else { + return(st_sf(mock_extra_tags, geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326))) + } + }, + oe_get_keys = function(...) c("lanes", "maxspeed"), + .package = "osmextract", + code = { + suppressWarnings({ # There will be warns about gtfs shapes not matched + res <- GTFShift::osm_shapes_to_routes( + gtfs, q = NA, ways = TRUE, + ways_tags = c("lanes", "maxspeed"), + osm_file = "dummy.pbf" + ) + }) + expect_s3_class(res, "sf") + expect_contains(names(res), c("shape_id", "osm_id", "way_osm_id", "lanes", "maxspeed", "geometry")) + expect_equal(res$way_osm_id, "w1") + expect_equal(res$lanes, "2") + expect_equal(res$maxspeed, "50") + } + ) + } + ) +}) + + + +test_that("osm_shapes_to_routes with ways = TRUE and osm_file = NULL extracts ways and ways_tags", { + sample_file <- system.file("extdata/samples", "gtfs_tcb_sample.zip", package = "GTFShift") + gtfs <- GTFShift::load_feed(sample_file) + + target_shape_id <- gtfs$trips$shape_id[1] + + mock_multilines <- st_sf( + osm_id = "rel_1", + `gtfs:shape_id` = target_shape_id, + geometry = st_sfc(st_multilinestring(list(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2))), crs = 4326) + ) + + mock_lines <- st_sf( + osm_id = "w1", + lanes = "3", + maxspeed = "60", + geometry = st_sfc(st_linestring(matrix(c(-8.6, -8.61, 41.1, 41.11), ncol = 2)), crs = 4326) + ) + + mock_osm_data <- list( + osm_multilines = mock_multilines, + osm_lines = mock_lines + ) + + mock_bg_job_sf <- list( + is_alive = function() FALSE, + get_result = function() mock_osm_data + ) + + mock_bg_job_xml <- list( + is_alive = function() FALSE, + get_result = function() NULL + ) + + mock_relations_df <- data.frame( + type = "way", + ref = "w1", + role = "forward", + relation_osm_id = "rel_1", + stringsAsFactors = FALSE + ) + + r_bg_call_count <- 0 + + testthat::with_mocked_bindings( + r_bg = function(func, args, ...) { + r_bg_call_count <<- r_bg_call_count + 1 + if (r_bg_call_count == 1) { + return(mock_bg_job_xml) + } else if (r_bg_call_count == 2) { + return(mock_bg_job_sf) + } else { + return(list( + is_alive = function() FALSE, + get_result = function() mock_relations_df + )) + } + }, + .package = "callr", + code = { + suppressWarnings({ # There will be warns about gtfs shapes not matched + res <- GTFShift::osm_shapes_to_routes( + gtfs, q = "dummy_q", ways = TRUE, + ways_tags = c("lanes", "maxspeed"), + osm_file = NULL + ) + }) + expect_s3_class(res, "sf") + expect_contains(names(res), c("shape_id", "osm_id", "way_osm_id", "lanes", "maxspeed", "geometry")) + expect_equal(res$way_osm_id, "w1") + expect_equal(res$lanes, "3") + expect_equal(res$maxspeed, "60") + } + ) +}) + + + + + + diff --git a/tests/testthat/test-rt_average_speed.R b/tests/testthat/test-rt_average_speed.R new file mode 100644 index 00000000..8e441cb6 --- /dev/null +++ b/tests/testthat/test-rt_average_speed.R @@ -0,0 +1,167 @@ +library(testthat) +library(sf) + +test_that("rt_average_speed computes speeds along trip geometry", { + trip_geom <- st_sf( + trip_id = c("T1", "T2"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 1000, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(0, 100, 1000, 100), ncol = 2, byrow = TRUE)), + crs = 3857 + ) + ) + + rt_updates <- st_sf( + trip_id = c("T1", "T1", "UNMATCHED_TRIP", "T2", "T2"), + timestamp = c(1000, 1060, 1070, 1080, 1140), + geometry = st_sfc( + st_point(c(0, 0)), + st_point(c(500, 10)), # Offset by 10m off line + st_point(c(600, 0)), + st_point(c(0, 100)), + st_point(c(400, 100)), + crs = 3857 + ) + ) + + expect_warning( + res <- GTFShift::rt_average_speed(rt_updates, trip_geom, metric_crs = 3857, geometry_sample_meters = 1), + "Trip UNMATCHED_TRIP has less than 2 updates. Ignoring it." + ) + expect_s3_class(res, "sf") + expect_equal(nrow(res), 4) + expect_contains(unique(res$trip_id), c("T1", "T2")) + expect_false("UNMATCHED_TRIP" %in% res$trip_id) + + expected_cols <- c( + "trip_id", + "timestamp", + "geometry", + "distance_along_geometry", + "distance_along_geometry_reversed", + "distance_to_closest_on_geometry", + "time_since_prev_sec", + "distance_since_prev_meters", + "speed_kmh" + ) + expect_contains(names(res), expected_cols) + + # Validate first observation in T1 (timestamp == 1000: previous values and speed are NA) + r_t1_1 <- res[res$trip_id == "T1" & res$timestamp == 1000, ] + expect_equal(nrow(r_t1_1), 1) + expect_equal(r_t1_1$distance_along_geometry, 0) + expect_equal(r_t1_1$distance_along_geometry_reversed, 1000) + expect_equal(r_t1_1$distance_to_closest_on_geometry, 0) + expect_true(is.na(r_t1_1$time_since_prev_sec)) + expect_true(is.na(r_t1_1$distance_since_prev_meters)) + expect_true(is.na(r_t1_1$speed_kmh)) + + # Validate second observation in T1 (timestamp == 1060 offset by 10m off line: distance_to_closest_on_geometry == 10) + r_t1_2 <- res[res$trip_id == "T1" & res$timestamp == 1060, ] + expect_equal(nrow(r_t1_2), 1) + expect_equal(r_t1_2$time_since_prev_sec, 60) + expect_equal(r_t1_2$distance_along_geometry, 500, tolerance = 1e-2) + expect_equal(r_t1_2$distance_along_geometry_reversed, 500, tolerance = 1e-2) + expect_equal(r_t1_2$distance_to_closest_on_geometry, 10, tolerance = 1e-2) + expect_equal(r_t1_2$distance_since_prev_meters, 500, tolerance = 1e-2) + expect_equal(r_t1_2$speed_kmh, 30, tolerance = 0.5) + + # Validate trip T2 (timestamp == 1080: first update, speed is NA) + r_t2_1 <- res[res$trip_id == "T2" & res$timestamp == 1080, ] + expect_equal(nrow(r_t2_1), 1) + expect_true(is.na(r_t2_1$speed_kmh)) + + # Validate trip T2 (timestamp == 1140: second update, distance 400m over 60s -> 24 km/h) + r_t2_2 <- res[res$trip_id == "T2" & res$timestamp == 1140, ] + expect_equal(nrow(r_t2_2), 1) + expect_equal(r_t2_2$time_since_prev_sec, 60) + expect_equal(r_t2_2$distance_since_prev_meters, 400, tolerance = 1e-2) + expect_equal(r_t2_2$distance_along_geometry, 400, tolerance = 1e-2) + expect_equal(r_t2_2$distance_along_geometry_reversed, 600, tolerance = 1e-2) + expect_equal(r_t2_2$speed_kmh, 24, tolerance = 0.5) +}) + +test_that("rt_average_speed issues warning and ignores trips with less than 2 updates", { + trip_geom <- st_sf( + trip_id = "T1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1000, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + + rt_updates_single <- st_sf( + trip_id = "T1", + timestamp = 1000, + geometry = st_sfc(st_point(c(0, 0)), crs = 3857) + ) + + expect_warning( + res <- GTFShift::rt_average_speed(rt_updates_single, trip_geom, metric_crs = 3857), + "Trip T1 has less than 2 updates. Ignoring it." + ) + expect_equal(nrow(res), 0) +}) + +test_that("rt_average_speed stops on invalid inputs and mismatched columns", { + trip_geom <- st_sf( + trip_id = "T1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1000, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + + rt_updates <- st_sf( + trip_id = c("T1", "T1"), + timestamp = c(1000, 1060), + geometry = st_sfc( + st_point(c(0, 0)), + st_point(c(500, 0)), + crs = 3857 + ) + ) + + # Non-sf rt_collection + expect_error( + GTFShift::rt_average_speed(data.frame(trip_id = "T1"), trip_geom), + "rt_collection must be an sf object" + ) + + # Non-sf trips_geometries + expect_error( + GTFShift::rt_average_speed(rt_updates, data.frame(trip_id = "T1")), + "trips_geometries must be an sf object" + ) + + # MULTILINESTRING trip geometry + multiline_geom <- st_sf( + trip_id = "T1", + geometry = st_sfc(st_multilinestring(list(matrix(c(0, 0, 500, 0), ncol = 2, byrow = TRUE))), crs = 3857) + ) + expect_error( + GTFShift::rt_average_speed(rt_updates, multiline_geom), + "trips_geometries geometry must be LINESTRING" + ) + + # Missing match column in rt_collection + expect_error( + GTFShift::rt_average_speed(rt_updates, trip_geom, rt_collection_trips_geometries_match_col = "missing_col"), + "rt_collection_trips_geometries_match_col must be one of the columns in rt_collection" + ) + + # Missing match column in trips_geometries + trip_geom_other_col <- st_sf( + other_id = "T1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 1000, 0), ncol = 2, byrow = TRUE)), crs = 3857) + ) + expect_error( + GTFShift::rt_average_speed(rt_updates, trip_geom_other_col, rt_collection_trips_geometries_match_col = "trip_id"), + "rt_collection_trips_geometries_match_col must be one of the columns in trips_geometries" + ) + + # Missing required timestamp column + rt_no_time <- st_sf( + trip_id = c("T1", "T1"), + geometry = st_sfc(st_point(c(0, 0)), st_point(c(500, 0)), crs = 3857) + ) + expect_error( + GTFShift::rt_average_speed(rt_no_time, trip_geom), + "rt_collection is missing required columns" + ) +}) + diff --git a/tests/testthat/test-rt_collect_json.R b/tests/testthat/test-rt_collect_json.R new file mode 100644 index 00000000..2c13e95a --- /dev/null +++ b/tests/testthat/test-rt_collect_json.R @@ -0,0 +1,211 @@ +library(testthat) + +test_that("rt_collect_json extracts JSON feed data and appends to CSV destination", { + dest_file <- withr::local_tempfile(fileext = ".csv") + parsed_json <- list( + header = list(timestamp = 1700000000), + entity = list(list(id = "1", vehicle = list(trip = list(trip_id = "t1"), position = list(latitude = 41.1, longitude = -8.6)))) + ) + + testthat::with_mocked_bindings( + fromJSON = function(...) parsed_json, + .package = "jsonlite", + code = { + GTFShift::rt_collect_json( + gtfs_rt_url = "http://example.com/rt.json", + destination_file = dest_file, + scrape_interval = -1 + ) + } + ) + + expect_true(file.exists(dest_file)) + res_df <- read.csv(dest_file) + expect_equal(nrow(res_df), 1) +}) + +test_that("headers are passed and httr is mocked", { + dest_file <- withr::local_tempfile(fileext = ".csv") + URL <- "http://example.com/rt.json" + headers <- c("Authorization" = "Bearer token123") + + captured_url <- NULL + captured_headers <- NULL + + parsed_json <- list( + header = list(timestamp = 1700000000), + entity = list(list(id = "1", vehicle = list(trip = list(trip_id = "t1"), position = list(latitude = 41.1, longitude = -8.6)))) + ) + + testthat::with_mocked_bindings( + GET = function(url, config, ...) { + captured_url <<- url + captured_headers <<- config$headers + structure(list(status_code = 200), class = "response") + }, + stop_for_status = function(res) { + NULL + }, + content = function(res, as = "text", encoding = "UTF-8") { + '{"mock":"json"}' + }, + .package = "httr", + code = { + testthat::with_mocked_bindings( + fromJSON = function(...) parsed_json, + .package = "jsonlite", + code = { + GTFShift::rt_collect_json( + gtfs_rt_url = URL, + destination_file = dest_file, + scrape_interval = -1, + headers = headers + ) + } + ) + } + ) + + expect_equal(captured_url, URL) + expect_equal(captured_headers, headers) + expect_true(file.exists(dest_file)) + res_df <- read.csv(dest_file) + expect_equal(nrow(res_df), 1) +}) + +test_that("parameter variation: log_file", { + dest_file <- withr::local_tempfile(fileext = ".csv") + log_file <- withr::local_tempfile(fileext = ".log") + parsed_json <- list( + header = list(timestamp = 1700000000), + entity = list(list(id = "1", vehicle = list(trip = list(trip_id = "t1"), position = list(latitude = 41.1, longitude = -8.6)))) + ) + + testthat::with_mocked_bindings( + fromJSON = function(...) parsed_json, + .package = "jsonlite", + code = { + GTFShift::rt_collect_json( + gtfs_rt_url = "http://example.com/rt.json", + destination_file = dest_file, + scrape_interval = -1, + log_file = log_file + ) + } + ) + + expect_true(file.exists(log_file)) + log_content <- readLines(log_file) + expect_true(any(grepl("Starting GTFS-RT data collection", log_content))) + expect_true(any(grepl("Iteration 1 completed", log_content))) +}) + +test_that("parameter variation: entity_key custom and NA", { + # Custom entity key + dest_file1 <- withr::local_tempfile(fileext = ".csv") + parsed_json_custom <- list( + header = list(timestamp = 1700000000), + custom_entities = list(list(id = "99", vehicle = list(trip = list(trip_id = "t99"), position = list(latitude = 40.0, longitude = -8.0)))) + ) + + testthat::with_mocked_bindings( + fromJSON = function(...) parsed_json_custom, + .package = "jsonlite", + code = { + GTFShift::rt_collect_json( + gtfs_rt_url = "http://example.com/rt.json", + destination_file = dest_file1, + entity_key = "custom_entities", + scrape_interval = -1 + ) + } + ) + + res_df1 <- read.csv(dest_file1) + expect_equal(nrow(res_df1), 1) + expect_equal(res_df1$id, 99) + + # NA entity key (flat list) + dest_file2 <- withr::local_tempfile(fileext = ".csv") + parsed_json_flat <- data.frame(id = "100", vehicle.trip.trip_id = "t100", vehicle.position.latitude = 42.0, vehicle.position.longitude = -8.5) + + testthat::with_mocked_bindings( + fromJSON = function(...) parsed_json_flat, + .package = "jsonlite", + code = { + GTFShift::rt_collect_json( + gtfs_rt_url = "http://example.com/rt.json", + destination_file = dest_file2, + header_key = NA, + entity_key = NA, + scrape_interval = -1 + ) + } + ) + + res_df2 <- read.csv(dest_file2) + expect_equal(nrow(res_df2), 1) + expect_equal(res_df2$id, 100) +}) + +test_that("test incrementality in response", { + dest_file <- withr::local_tempfile(fileext = ".csv") + parsed_json <- list( + header = list(timestamp = 1700000000, incrementality = "FULL_DATASET"), + entity = list(list(id = "1", vehicle = list(trip = list(trip_id = "t1"), position = list(latitude = 41.1, longitude = -8.6)))) + ) + + testthat::with_mocked_bindings( + fromJSON = function(...) parsed_json, + .package = "jsonlite", + code = { + GTFShift::rt_collect_json( + gtfs_rt_url = "http://example.com/rt.json", + destination_file = dest_file, + scrape_interval = -1 + ) + } + ) + + res_df <- read.csv(dest_file) + expect_true("feed_incrementality" %in% names(res_df)) + expect_equal(res_df$feed_incrementality, "FULL_DATASET") +}) + +test_that("scrape_interval performs at least 3 requests", { + dest_file <- withr::local_tempfile(fileext = ".csv") + parsed_json <- list( + header = list(timestamp = 1700000000), + entity = list(list(id = "1", vehicle = list(trip = list(trip_id = "t1"), position = list(latitude = 41.1, longitude = -8.6)))) + ) + + request_count <- 0 + start_time <- Sys.time() + + testthat::with_mocked_bindings( + fromJSON = function(...) { + request_count <<- request_count + 1 + if (request_count > 3) { + stop("stop_loop_after_3_requests") + } + parsed_json + }, + .package = "jsonlite", + code = { + expect_error( + GTFShift::rt_collect_json( + gtfs_rt_url = "http://example.com/rt.json", + destination_file = dest_file, + scrape_interval = 1 + ), + "stop_loop_after_3_requests" + ) + } + ) + + elapsed_time <- as.numeric(difftime(Sys.time(), start_time, units = "secs")) + expect_equal(request_count, 4) + res_df <- read.csv(dest_file) + expect_equal(nrow(res_df), 3) + expect_gte(elapsed_time, 3) +}) diff --git a/tests/testthat/test-rt_collect_protobuf.R b/tests/testthat/test-rt_collect_protobuf.R new file mode 100644 index 00000000..025c1248 --- /dev/null +++ b/tests/testthat/test-rt_collect_protobuf.R @@ -0,0 +1,193 @@ +library(testthat) + +test_that("rt_collect_protobuf decodes protobuf and passes to rt_collect_json via mocks", { + dest_file <- withr::local_tempfile(fileext = ".csv") + pb_file <- withr::local_tempfile(fileext = ".pb") + file.create(pb_file) + + testthat::with_mocked_bindings( + readProtoFiles = function(...) TRUE, + P = function(...) TRUE, + read = function(...) structure(list(id = "1"), class = "Message"), + .package = "RProtoBuf", + code = { + testthat::with_mocked_bindings( + rt_collect_json = function(...) { + write.table(data.frame(id = "1"), file = dest_file, sep = ",", row.names = FALSE) + }, + .package = "GTFShift", + code = { + GTFShift::rt_collect_protobuf( + gtfs_rt_url = pb_file, + destination_file = dest_file, + scrape_interval = -1 + ) + } + ) + } + ) + + expect_true(file.exists(dest_file)) +}) + +test_that("headers are passed and httr is mocked", { + dest_file <- withr::local_tempfile(fileext = ".csv") + URL <- "http://example.com/rt.pb" + headers <- c("Authorization" = "Bearer token123") + + captured_url <- NULL + captured_headers <- NULL + + testthat::with_mocked_bindings( + GET = function(url, config = list(), ...) { + captured_url <<- url + captured_headers <<- config$headers + dots <- list(config, ...) + for (arg in dots) { + if (inherits(arg, "write_disk") && !is.null(arg$path)) { + file.create(arg$path) + } + if (is.list(arg) && !is.null(arg$file)) { + file.create(arg$file) + } + } + structure(list(status_code = 200), class = "response") + }, + stop_for_status = function(res) { + NULL + }, + write_disk = function(path, overwrite = TRUE) { + structure(list(path = path), class = "write_disk") + }, + .package = "httr", + code = { + testthat::with_mocked_bindings( + readProtoFiles = function(...) TRUE, + P = function(...) TRUE, + read = function(...) structure(list(id = "1"), class = "Message"), + .package = "RProtoBuf", + code = { + testthat::with_mocked_bindings( + rt_collect_json = function(...) { + write.table(data.frame(id = "1"), file = dest_file, sep = ",", row.names = FALSE) + }, + .package = "GTFShift", + code = { + GTFShift::rt_collect_protobuf( + gtfs_rt_url = URL, + destination_file = dest_file, + scrape_interval = -1, + headers = headers + ) + } + ) + } + ) + } + ) + + expect_equal(captured_url, URL) + expect_equal(captured_headers, headers) + expect_true(file.exists(dest_file)) +}) + +test_that("parameter variation: log_file", { + dest_file <- withr::local_tempfile(fileext = ".csv") + pb_file <- withr::local_tempfile(fileext = ".pb") + file.create(pb_file) + log_file <- withr::local_tempfile(fileext = ".log") + + testthat::with_mocked_bindings( + readProtoFiles = function(...) TRUE, + P = function(...) TRUE, + read = function(...) structure(list(id = "1"), class = "Message"), + .package = "RProtoBuf", + code = { + testthat::with_mocked_bindings( + rt_collect_json = function(...) { + write.table(data.frame(id = "1"), file = dest_file, sep = ",", row.names = FALSE) + }, + .package = "GTFShift", + code = { + GTFShift::rt_collect_protobuf( + gtfs_rt_url = pb_file, + destination_file = dest_file, + scrape_interval = -1, + log_file = log_file + ) + } + ) + } + ) + + expect_true(file.exists(log_file)) + log_content <- readLines(log_file) + expect_true(any(grepl("Starting GTFS-RT data collection", log_content))) + expect_true(any(grepl("Iteration 1 completed", log_content))) +}) + +test_that("test incrementality in response", { + dest_file <- withr::local_tempfile(fileext = ".csv") + pb_file <- withr::local_tempfile(fileext = ".pb") + file.create(pb_file) + + msg_header <- structure(list(timestamp = 1700000000, incrementality = "FULL_DATASET"), class = "Message") + msg_entity <- list(structure(list(id = "1"), class = "Message")) + feed_msg <- structure(list(header = msg_header, entity = msg_entity), class = "Message") + + testthat::with_mocked_bindings( + readProtoFiles = function(...) TRUE, + P = function(...) TRUE, + read = function(...) feed_msg, + .package = "RProtoBuf", + code = { + GTFShift::rt_collect_protobuf( + gtfs_rt_url = pb_file, + destination_file = dest_file, + scrape_interval = -1 + ) + } + ) + + res_df <- read.csv(dest_file) + expect_true("feed_incrementality" %in% names(res_df)) + expect_equal(res_df$feed_incrementality, "FULL_DATASET") +}) + +test_that("scrape_interval performs at least 3 requests", { + dest_file <- withr::local_tempfile(fileext = ".csv") + pb_file <- withr::local_tempfile(fileext = ".pb") + file.create(pb_file) + + request_count <- 0 + start_time <- Sys.time() + + testthat::with_mocked_bindings( + readProtoFiles = function(...) TRUE, + P = function(...) TRUE, + read = function(...) { + request_count <<- request_count + 1 + if (request_count > 3) { + stop("stop_loop_after_3_requests") + } + structure(list(id = "1"), class = "Message") + }, + .package = "RProtoBuf", + code = { + expect_error( + GTFShift::rt_collect_protobuf( + gtfs_rt_url = pb_file, + destination_file = dest_file, + scrape_interval = 1 + ), + "stop_loop_after_3_requests" + ) + } + ) + + elapsed_time <- as.numeric(difftime(Sys.time(), start_time, units = "secs")) + expect_equal(request_count, 4) + res_df <- read.csv(dest_file) + expect_equal(nrow(res_df), 3) + expect_gte(elapsed_time, 3) +}) diff --git a/tests/testthat/test-rt_extend_prioritisation.R b/tests/testthat/test-rt_extend_prioritisation.R new file mode 100644 index 00000000..270f069d --- /dev/null +++ b/tests/testthat/test-rt_extend_prioritisation.R @@ -0,0 +1,108 @@ +library(testthat) +library(sf) + +test_that("rt_extend_prioritisation extends lane prioritisation with speed metrics for multiple entries", { + lanes_sf <- st_sf( + way_osm_id = c("w1", "w2"), + geometry = st_sfc( + st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), + st_linestring(matrix(c(200, 0, 300, 0), ncol = 2, byrow = TRUE)), + crs = 4326 + ) + ) + + rt_points <- st_sf( + speed = c(10, 20, 30, 40), + current_status = c("IN_TRANSIT_TO", "IN_TRANSIT_TO", "STOPPED_AT", "IN_TRANSIT_TO"), + geometry = st_sfc( + st_point(c(20, 0)), + st_point(c(50, 0)), + st_point(c(80, 0)), # Filtered out due to status STOPPED_AT + st_point(c(250, 0)), + crs = 4326 + ) + ) + + res <- GTFShift::rt_extend_prioritisation(lanes_sf, rt_points, metric_crs = 3857) + expect_s3_class(res, "sf") + expect_contains(names(res), c("speed_avg", "speed_median", "speed_p25", "speed_p75", "speed_count")) + + # For w1: speeds 10 and 20 (point 3 at 80 is STOPPED_AT so filtered out) + expect_equal(res$speed_avg[res$way_osm_id == "w1"], 15) + expect_equal(res$speed_median[res$way_osm_id == "w1"], 15) + expect_equal(unname(res$speed_p25[res$way_osm_id == "w1"]), 12.5) + expect_equal(unname(res$speed_p75[res$way_osm_id == "w1"]), 17.5) + expect_equal(res$speed_count[res$way_osm_id == "w1"], 2) + + # For w2: speed 40 + expect_equal(res$speed_avg[res$way_osm_id == "w2"], 40) + expect_equal(res$speed_count[res$way_osm_id == "w2"], 1) +}) + +test_that("rt_extend_prioritisation raises warning when metric_crs is default", { + lanes_sf <- st_sf( + way_osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 4326) + ) + + rt_points <- st_sf( + speed = 25, + current_status = "IN_TRANSIT_TO", + geometry = st_sfc(st_point(c(50, 0)), crs = 4326) + ) + + expect_warning( + GTFShift::rt_extend_prioritisation(lanes_sf, rt_points), + "Using default metric_crs" + ) +}) + +test_that("rt_extend_prioritisation stops when lane_prioritisation is missing way_osm_id column", { + invalid_lanes <- st_sf( + id = "w1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 4326) + ) + + rt_points <- st_sf( + speed = 25, + geometry = st_sfc(st_point(c(50, 0)), crs = 4326) + ) + + expect_error( + GTFShift::rt_extend_prioritisation(invalid_lanes, rt_points, metric_crs = 3857), + "lane_prioritisation is missing required columns: way_osm_id" + ) +}) + +test_that("rt_extend_prioritisation stops when rt_collection is missing speed column", { + lanes_sf <- st_sf( + way_osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 4326) + ) + + invalid_rt <- st_sf( + velocity = 25, + geometry = st_sfc(st_point(c(50, 0)), crs = 4326) + ) + + expect_error( + GTFShift::rt_extend_prioritisation(lanes_sf, invalid_rt, metric_crs = 3857), + "rt_collection is missing required columns: speed" + ) +}) + +test_that("rt_extend_prioritisation stops when metric_crs is invalid", { + lanes_sf <- st_sf( + way_osm_id = "w1", + geometry = st_sfc(st_linestring(matrix(c(0, 0, 100, 0), ncol = 2, byrow = TRUE)), crs = 4326) + ) + + rt_points <- st_sf( + speed = 25, + geometry = st_sfc(st_point(c(50, 0)), crs = 4326) + ) + + expect_error( + GTFShift::rt_extend_prioritisation(lanes_sf, rt_points, metric_crs = NA) + ) +}) diff --git a/tests/testthat/test-unify.R b/tests/testthat/test-unify.R new file mode 100644 index 00000000..f20cb053 --- /dev/null +++ b/tests/testthat/test-unify.R @@ -0,0 +1,94 @@ +library(testthat) + +test_that("unify merges two GTFS feeds with default parameters", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs1 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(8) + gtfs2 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(4) + + merge_gtfs_called <- FALSE + real_merge <- gtfstools::merge_gtfs + + testthat::with_mocked_bindings( + merge_gtfs = function(...) { + merge_gtfs_called <<- TRUE + real_merge(...) + }, + .package = "gtfstools", + code = { + unified <- GTFShift::unify(gtfs1, gtfs2) + expect_true(merge_gtfs_called) + expect_s3_class(unified, "tidygtfs") + expect_contains(names(unified), c("agency", "routes", "stops", "trips")) + expect_equal(length(unique(unified$agency$agency_id)), 2) + expect_contains(unique(unified$agency$agency_id), c("8", "4")) + } + ) +}) + +test_that("unify supports prefix = TRUE", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs1 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(8) + gtfs2 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(4) + + unified_prefix <- GTFShift::unify(gtfs1, gtfs2, prefix = TRUE) + expect_s3_class(unified_prefix, "tidygtfs") + expect_true(any(grepl("^8_", unified_prefix$routes$route_id))) + expect_true(any(grepl("^4_", unified_prefix$routes$route_id))) + + expect_true(any(grepl("^8_", unified_prefix$stops$stop_id))) + expect_true(any(grepl("^4_", unified_prefix$stops$stop_id))) + + expect_true(any(grepl("^8_", unified_prefix$trips$trip_id))) + expect_true(any(grepl("^4_", unified_prefix$trips$trip_id))) + + expect_true(any(grepl("^8_", unified_prefix$shapes$shape_id))) + expect_true(any(grepl("^4_", unified_prefix$shapes$shape_id))) + + expect_true(any(grepl("^8_", unified_prefix$calendar$service_id))) + expect_true(any(grepl("^4_", unified_prefix$calendar$service_id))) +}) + +test_that("unify supports create_transfers = TRUE with custom transfer_distance and transfer_time", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs1 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(8) + gtfs2 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(4) + + unified_transfers <- GTFShift::unify( + gtfs1, + gtfs2, + create_transfers = TRUE, + transfer_distance = 500, + transfer_time = 180, + transfer_street_routing = FALSE + ) + + expect_s3_class(unified_transfers, "tidygtfs") + expect_true("transfers" %in% names(unified_transfers)) + expect_gt(nrow(unified_transfers$transfers), 0) +}) + +test_that("unify stores feed to store_path", { + sample_file <- system.file("extdata/samples", "gtfs_merged_sample.zip", package = "GTFShift") + gtfs1 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(8) + gtfs2 <- GTFShift::load_feed(sample_file) |> GTFShift::filter_by_agency(4) + + tmp_dir <- withr::local_tempfile() + tmp_zip <- file.path(tmp_dir, "nested", "unified_out.zip") + + unified <- GTFShift::unify(gtfs1, gtfs2, store_path = tmp_zip) + expect_true(file.exists(tmp_zip)) + testthat::expect_true(file.size(tmp_zip) > 0) + zip::zip_list(tmp_zip) |> + dplyr::pull(filename) |> + testthat::expect_contains(c("agency.txt", "routes.txt", "trips.txt", "stops.txt", "stop_times.txt", "shapes.txt")) + + # Clean up + unlink(tmp_dir, recursive = TRUE) +}) + +test_that("unify stops on invalid input feeds", { + expect_error( + GTFShift::unify("not_a_gtfs_object"), + "Must inherit from class 'gtfs'" + ) +}) diff --git a/vignettes/articles/GTFShift.Rmd b/vignettes/articles/GTFShift.Rmd index a7a0b314..287f01f4 100644 --- a/vignettes/articles/GTFShift.Rmd +++ b/vignettes/articles/GTFShift.Rmd @@ -27,14 +27,14 @@ library(GTFShift) # Key functions **GTFShift** provides methods for the entire workflow of bus lane implementation -prioritization, but also other useful functions for GTFS and OSM data gathering +prioritisation, but also other useful functions for GTFS and OSM data gathering and manipulation. For detailed examples on their functionality, refer to the [articles](./index.html). -### [Prioritize](./prioritize.html) +### [Prioritise](./prioritise.html) The main purpose of **GTFShift** is to support the decision-making process for -bus lane implementation prioritization. This article presents a step-by-step guide +bus lane implementation prioritisation. This article presents a step-by-step guide on how to use the package to achieve this goal, from data gathering to analysis and visualization. ### [Getting transit data](./download.html) diff --git a/vignettes/analyse.Rmd b/vignettes/articles/analyse.Rmd similarity index 98% rename from vignettes/analyse.Rmd rename to vignettes/articles/analyse.Rmd index a46008cb..a896dfd4 100644 --- a/vignettes/analyse.Rmd +++ b/vignettes/articles/analyse.Rmd @@ -162,7 +162,7 @@ summary(frequencies_route) quantile(frequencies_route$frequency) ``` -The `overline` parameter allows for an even more aggregated screening of the operation, clustering routes that overlap and converting them into a single route network. This allows for a better visualization of the volumes of frequencies per each segment of the network and can help prioritizing interventions in the network. +The `overline` parameter allows for an even more aggregated screening of the operation, clustering routes that overlap and converting them into a single route network. This allows for a better visualization of the volumes of frequencies per each segment of the network and can help prioritising interventions in the network. ```{r include=FALSE} frequencies_route_overline = sf::st_read("https://github.com/U-Shift/GTFShift/releases/download/v0.7.0/analyse_carris_route_frequency_hourly_overline.gpkg") @@ -234,7 +234,7 @@ GTFShift offers several methods that allow to get routes geometry from OpenStree There are several methods to aggregate a transit network. One approach is through the determination of the centerlines of the roads where the vehicles operate. GTFShift provides a method that encapsulates Python [neatnet](https://uscuni.org/neatnet/index.html) package for this purpose. Refer to [vignette("osm")](osm.html#get-centerlines-for-osm-road-network) for more details. -> During the development of this project, no R packages were found suiting this purpose. [Centerline](https://github.com/atsyplenkov/centerline) package has this feature in its roadmap. Currently, there are available solutions for [Python](https://uscuni.org/neatnet/index.html) or [ArcGis](https://pro.arcgis.com/en/pro-app/latest/tool-reference/cartography/merge-divided-roads.htm). +> During the development of this project, no R packages were found suiting this purpose. [Centerline](https://github.com/atsyplenkov/centerline) package has this feature in its roadmap. Currently, there are available solutions for [Python](https://uscuni.org/neatnet/index.html) or [ArcGIS](https://pro.arcgis.com/en/pro-app/latest/tool-reference/cartography/merge-divided-roads.htm). ## Aggregating frequencies over a target network @@ -243,7 +243,7 @@ As an alternative to the `GTFShift::get_route_frequency_hourly()` method using t Given a target network, it identifies the segments corresponding to each route and uses them to aggregate the attribute defined in the parameters. -Below is provided an example, that uses the centerlines for the Carris network as a target network, generated using [ArcGis](https://pro.arcgis.com/en/pro-app/latest/tool-reference/cartography/merge-divided-roads.htm). GTFShift provides `GTFShift::osm_centerlines()` method to generate this kind of network from OSM data. Refer to [vignette("osm")](osm.html#get-centerlines-for-osm-road-network) for more details. +Below is provided an example, that uses the centerlines for the Carris network as a target network, generated using [ArcGIS](https://pro.arcgis.com/en/pro-app/latest/tool-reference/cartography/merge-divided-roads.htm). GTFShift provides `GTFShift::osm_centerlines()` method to generate this kind of network from OSM data. Refer to [vignette("osm")](osm.html#get-centerlines-for-osm-road-network) for more details. ```{r include=FALSE} frequencies_route_overline_improved = sf::st_read("https://github.com/U-Shift/GTFShift/releases/download/v0.7.0/analyse_carris_route_frequency_network_overline.gpkg") diff --git a/vignettes/classify.Rmd b/vignettes/articles/classify.Rmd similarity index 100% rename from vignettes/classify.Rmd rename to vignettes/articles/classify.Rmd diff --git a/vignettes/download.Rmd b/vignettes/articles/download.Rmd similarity index 98% rename from vignettes/download.Rmd rename to vignettes/articles/download.Rmd index 7a3d8edc..f3b4158a 100644 --- a/vignettes/download.Rmd +++ b/vignettes/articles/download.Rmd @@ -63,7 +63,7 @@ It queries the `/v1/gtfs_feeds` API endpoint, returning a list of GTFS feeds wit To use it, an access token must be provided. It can be obtained for free at Mobility Database [website](https://mobilitydatabase.org/account). -```{r} +```{r eval = nzchar(Sys.getenv("MOBILITY_DATABASE"))} aml = sf::st_read("https://github.com/U-Shift/MQAT/raw/refs/heads/main/geo/MUNICIPIOSgeo.gpkg", quiet = TRUE) |> sf::st_bbox() # usethis::edit_r_environ() # to set MOBILITY_DATABASE variable for this code chunk to work diff --git a/vignettes/analyse_overline_error.png b/vignettes/articles/figures/analyse_overline_error.png similarity index 100% rename from vignettes/analyse_overline_error.png rename to vignettes/articles/figures/analyse_overline_error.png diff --git a/vignettes/figures/hcm_ex_27_1.png b/vignettes/articles/figures/hcm_ex_27_1.png similarity index 100% rename from vignettes/figures/hcm_ex_27_1.png rename to vignettes/articles/figures/hcm_ex_27_1.png diff --git a/vignettes/figures/prioritization.png b/vignettes/articles/figures/prioritization.png similarity index 100% rename from vignettes/figures/prioritization.png rename to vignettes/articles/figures/prioritization.png diff --git a/vignettes/filter.Rmd b/vignettes/articles/filter.Rmd similarity index 100% rename from vignettes/filter.Rmd rename to vignettes/articles/filter.Rmd diff --git a/vignettes/gtfs_from_osm.Rmd b/vignettes/articles/gtfs_from_osm.Rmd similarity index 100% rename from vignettes/gtfs_from_osm.Rmd rename to vignettes/articles/gtfs_from_osm.Rmd diff --git a/vignettes/osm.Rmd b/vignettes/articles/osm.Rmd similarity index 100% rename from vignettes/osm.Rmd rename to vignettes/articles/osm.Rmd diff --git a/vignettes/osm_update.Rmd b/vignettes/articles/osm_update.Rmd similarity index 100% rename from vignettes/osm_update.Rmd rename to vignettes/articles/osm_update.Rmd diff --git a/vignettes/prioritize.Rmd b/vignettes/articles/prioritise.Rmd similarity index 86% rename from vignettes/prioritize.Rmd rename to vignettes/articles/prioritise.Rmd index 68849011..e6536977 100644 --- a/vignettes/prioritize.Rmd +++ b/vignettes/articles/prioritise.Rmd @@ -1,8 +1,8 @@ --- -title: "Prioritize bus lane implementation" +title: "Prioritise bus lane implementation" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Prioritize bus lane implementation} + %\VignetteIndexEntry{Prioritise bus lane implementation} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -52,15 +52,15 @@ GTFShift provides methods to analyse these dimensions, namely: - `GTFShift::osm_bus_lanes()`, to identify existing bus lanes in the road network. -- `GTFShift::rt_collect_json()` or `GTFShift::rt_collect_protobuf()`, to collect GTFS-RT data, which can be later used with `GTFShift::rt_extend_prioritization()` to include real-time operational metrics in the prioritization analysis. +- `GTFShift::rt_collect_json()` or `GTFShift::rt_collect_protobuf()`, to collect GTFS-RT data, which can be later used with `GTFShift::rt_extend_prioritisation()` to include real-time operational metrics in the prioritisation analysis. -This document explores how to use these methods in a combined way to assist public transport planners in prioritizing bus lane implementations. For details on the several encapsulated features and method variations, refer to the numbered articles in the menu, that explore in detail each of the specific approaches followed. +This document explores how to use these methods in a combined way to assist public transport planners in prioritising bus lane implementations. For details on the several encapsulated features and method variations, refer to the numbered articles in the menu, that explore in detail each of the specific approaches followed. -# Prioritize lanes +# Prioritise lanes ## Generate base indicators -`GTFShift::prioritize_lanes()` is a simple method that generates indicators for most of the criteria mentioned above using GTFS and OpenStreetMaps data (service frequency and lane characteristics). With a single call, it returns a data.frame with the relevant metrics for each road segment with transit service. +`GTFShift::prioritise_lanes()` is a simple method that generates indicators for most of the criteria mentioned above using GTFS and OpenStreetMaps data (service frequency and lane characteristics). With a single call, it returns a data.frame with the relevant metrics for each road segment with transit service. ```{r include=FALSE} lanes <- sf::st_read("https://github.com/U-Shift/GTFShift/releases/download/v0.8.1/prioritization_lisboa_rt_gtfs2026-02-04_run20260226.gpkg") @@ -77,7 +77,7 @@ osm_q <- opq(bbox = sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> add_osm_feature(key = "route", value = c("bus", "tram")) |> add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) -lanes <- prioritize_lanes(gtfs, osm_q) +lanes <- prioritise_lanes(gtfs, osm_q) ``` ```{r} @@ -88,14 +88,14 @@ summary(lanes) ## Extend with GTFS-RT data -If GTFS-RT data is available, it can be used to extend the prioritization analysis with real-time operational metrics, such as average speed. This can help identify road segments where buses are experiencing significant delays due to traffic congestion, which may benefit from bus lane implementation. +If GTFS-RT data is available, it can be used to extend the prioritisation analysis with real-time operational metrics, such as average speed. This can help identify road segments where buses are experiencing significant delays due to traffic congestion, which may benefit from bus lane implementation. ```{r eval=FALSE} rt_collection <- read.csv("rt_collect_file.csv") |> sf::st_as_sf(coords = c("vehicle.position.longitude", "vehicle.position.latitude"), crs = 4326) -lanes <- GTFShift::rt_extend_prioritization( - lane_prioritization = lanes, +lanes <- GTFShift::rt_extend_prioritisation( + lane_prioritisation = lanes, rt_collection = rt_collection ) ``` @@ -104,30 +104,30 @@ lanes <- GTFShift::rt_extend_prioritization( lanes <- sf::st_read("https://github.com/U-Shift/GTFShift/releases/download/v0.8.1/prioritization_lisboa_rt_gtfs2026-02-04_run20260226_extended.gpkg") ``` -Refer to the [GTFS Real Time](./rt.html) article for details on how to collect GTFS-RT data and extend the prioritization analysis. +Refer to the [GTFS Real Time](./rt.html) article for details on how to collect GTFS-RT data and extend the prioritisation analysis. ## Analyze results -Method `GTFShift::get_prioritization_stats()` can be used to obtain statistics about lane prioritization, weighted by length and/or frequency. +Method `GTFShift::get_prioritisation_stats()` can be used to obtain statistics about lane prioritisation, weighted by length and/or frequency. ```{r} # For network analysis, frequency weight is more appropriate, # to give more importance to the segments with more service lanes_0800 <- lanes |> filter(hour == 8) -stats <- GTFShift::get_prioritization_stats(lanes_0800, weight = "frequency") +stats <- GTFShift::get_prioritisation_stats(lanes_0800, weight = "frequency") stats # At route level, length weight is more appropriate, # to give more importance to the segments with higher extension, # as the frequency does not vary along the route lanes_0800_736 <- lanes |> filter(hour == 8 & grepl("199_0", routes)) -stats_736 <- GTFShift::get_prioritization_stats(lanes_0800_736, weight = "length") +stats_736 <- GTFShift::get_prioritisation_stats(lanes_0800_736, weight = "length") stats_736 ``` ## Visualize results -The aggregated data can then be manipulated according to the prioritization criteria defined by the user. For instance, the following code highlights (in red) the road segments as high priority for bus lane implementation if they have more than 1 lane per direction and a frequency above the median number of buses per hour registered at 8:00. +The aggregated data can then be manipulated according to the prioritisation criteria defined by the user. For instance, the following code highlights (in red) the road segments as high priority for bus lane implementation if they have more than 1 lane per direction and a frequency above the median number of buses per hour registered at 8:00. ```{r cache=FALSE, include=FALSE} mapviewOptions( @@ -167,4 +167,4 @@ mapview::mapview( ) ``` -This visual representation allows to easily identify not only the high-priority segments for bus lane implementation, but also their spatial distribution across the existent network. A process that extends the results by incorporating the network continuity perspective, enabling the identification and eventual prioritization of critical segments that connect bus lanes but have a bad performance. +This visual representation allows to easily identify not only the high-priority segments for bus lane implementation, but also their spatial distribution across the existent network. A process that extends the results by incorporating the network continuity perspective, enabling the identification and eventual prioritisation of critical segments that connect bus lanes but have a bad performance. diff --git a/vignettes/rt.Rmd b/vignettes/articles/rt.Rmd similarity index 80% rename from vignettes/rt.Rmd rename to vignettes/articles/rt.Rmd index 4fe3a90e..5fd0a861 100644 --- a/vignettes/rt.Rmd +++ b/vignettes/articles/rt.Rmd @@ -49,20 +49,20 @@ rt_collect_file <- "gtfs_rt_data.csv" GTFShift::rt_collect_protobuf(data$URL.RT[data$ID == gtfs_id], rt_collect_file) # Run until manually stopped (CTRL+C) ``` -# Extend prioritization with speed from GTFS-RT data +# Extend prioritisation with speed from GTFS-RT data -Once GTFS-RT data is collected, it can be used to extend lane prioritization analysis. -`GTFShift::rt_extend_prioritization()` takes a lane prioritization data frame and a GTFS-RT collection (as an `sf` object) and enriches the prioritization with real-time metrics. +Once GTFS-RT data is collected, it can be used to extend lane prioritisation analysis. +`GTFShift::rt_extend_prioritisation()` takes a lane prioritisation data frame and a GTFS-RT collection (as an `sf` object) and enriches the prioritisation with real-time metrics. Refer to the method documentation for the full details. ```{r, eval=FALSE} -# Prioritization based on static GTFS data and infrastructure characteristics +# Prioritisation based on static GTFS data and infrastructure characteristics gtfs = GTFShift::load_feed(data$URL[data$ID == gtfs_id], create_transfers=FALSE) osm_q = opq(bbox=sf::st_bbox(tidytransit::shapes_as_sf(gtfs$shapes))) |> add_osm_feature(key = "route", value = c("bus", "tram")) |> add_osm_feature(key = "network", value = "Carris", key_exact = TRUE) -lane_prioritization <- GTFShift::prioritize_lanes(gtfs, osm_query) +lane_prioritisation <- GTFShift::prioritise_lanes(gtfs, osm_query) # GTFS-RT data preparation rt_collection = read.csv("rt_collect_file.csv") |> @@ -77,15 +77,15 @@ within_distance = st_is_within_distance( ) rt_collection_filtered = rt_collection[lengths(within_distance) == 0, ] -# Prioritization extended with real-time data to add traffic conditions -lane_prioritization_extended <- GTFShift::rt_extend_prioritization( - lane_prioritization = lane_prioritization, +# Prioritisation extended with real-time data to add traffic conditions +lane_prioritisation_extended <- GTFShift::rt_extend_prioritisation( + lane_prioritisation = lane_prioritisation, rt_collection = rt_collection_filtered ) ``` ```{r include=FALSE} -lane_prioritization_extended = sf::st_read("https://github.com/U-Shift/GTFShift/releases/download/v0.8.1/prioritization_lisboa_rt_gtfs2026-02-04_run20260226_extended.gpkg") +lane_prioritisation_extended = sf::st_read("https://github.com/U-Shift/GTFShift/releases/download/v0.8.1/prioritization_lisboa_rt_gtfs2026-02-04_run20260226_extended.gpkg") ``` ```{r cache=FALSE, include=FALSE} @@ -95,34 +95,34 @@ mapviewOptions( ``` -The resulting `lane_prioritization_extended` data frame includes additional columns with speed metrics, such as average speed, median speed, and speed percentiles, providing a more comprehensive view of lane performance based on real-time data. +The resulting `lane_prioritisation_extended` data frame includes additional columns with speed metrics, such as average speed, median speed, and speed percentiles, providing a more comprehensive view of lane performance based on real-time data. ```{r cache=FALSE} -lane_prioritization_0800 = lane_prioritization_extended |> filter(hour==8) +lane_prioritisation_0800 = lane_prioritisation_extended |> filter(hour==8) mapview::mapview( - lane_prioritization_0800, + lane_prioritisation_0800, zcol = "speed_avg", layer.name = "Average speed per lane" ) -p50_frequency = quantile(lane_prioritization_0800$frequency, 0.5, na.rm=TRUE) -p50_speed = quantile(lane_prioritization_0800$speed_avg, 0.5, na.rm=TRUE) +p50_frequency = quantile(lane_prioritisation_0800$frequency, 0.5, na.rm=TRUE) +p50_speed = quantile(lane_prioritisation_0800$speed_avg, 0.5, na.rm=TRUE) mapview::mapview( - lane_prioritization_0800 |> filter(is_bus_lane & (frequency filter(is_bus_lane & (frequency filter(is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg>p50_speed), + lane_prioritisation_0800 |> filter(is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg>p50_speed), layer.name=sprintf("Bus lane with +%d bus/h AND +1 lane/dir AND +%.2f km/h avg.speed", p50_frequency-1, p50_speed), color="#3BC1A8", homebutton=FALSE, lwd=3 ) + mapview::mapview( - lane_prioritization_0800 |> filter(!is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg<=p50_speed), + lane_prioritisation_0800 |> filter(!is_bus_lane & frequency>=p50_frequency & !is.na(n_lanes) & n_lanes_direction>1 & speed_avg<=p50_speed), layer.name=sprintf("NO bus lane with +%d bus/h AND +1 lane/dir AND %.2f km/h or - avg.speed", p50_frequency-1, p50_speed), color="#F63049", homebutton=FALSE, @@ -137,4 +137,4 @@ The method `GTFShift::rt_average_speed()` implements this functionality, calcula based on the distance between the current and previous position (projected on the route geometry), divided by the time difference between the two updates. -For more details, refer to the method documentation. The resulting speed can then be used to extend the prioritization analysis as described above. +For more details, refer to the method documentation. The resulting speed can then be used to extend the prioritisation analysis as described above. diff --git a/vignettes/unify.Rmd b/vignettes/articles/unify.Rmd similarity index 100% rename from vignettes/unify.Rmd rename to vignettes/articles/unify.Rmd diff --git a/vignettes/figures/analyse_overline_error.png b/vignettes/figures/analyse_overline_error.png deleted file mode 100644 index e5d423b2..00000000 Binary files a/vignettes/figures/analyse_overline_error.png and /dev/null differ