Merge pull request #75 from itsleeds/oweno-tfwm

Oweno tfwm v5

.github/workflows/test-coverage.yaml

@@ -44,7 +44,7 @@ jobs:
 
       - name: Upload test results
         if: failure()
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
           name: coverage-test-failures
           path: ${{ runner.temp }}/package

DESCRIPTION

@@ -1,12 +1,13 @@
 Package: UK2GTFS
 Type: Package
 Title: Converts UK transport timetable datasets to GTFS format
-Version: 0.2.1
+Version: 0.3.0
 Authors@R: c(
     person("Malcolm", "Morgan", email = "[email protected]", role = c("aut","cre"), 
       comment = c(ORCID = "0000-0002-9488-9183")),
     person("Adrian", "Schönig", role = c("ctb")),
-    person("Owen", "O'Neill",  role = c("ctb"))
+    person("Owen", "O'Neill", email = "[email protected]", role = c("aut"), 
+      comment = c(ORCID = "0009-0008-0595-3042"))
     )
 Maintainer: Malcolm Morgan <[email protected]>
 Description: The UK uses a range of odd formats to store timetable data, this package converts them to the nice GTFS format.
@@ -21,7 +22,6 @@ LazyDataCompression: gzip
 Imports:
   checkmate,
   calendar,
-  collapse,
   data.table,
   dodgr,
   dplyr,
@@ -31,12 +31,13 @@ Imports:
   geodist,
   httr,
   iotools,
-  stringr,
-  sf,
   lubridate,
   purrr (>= 1.0),
-  readr (>= 2.0),
   RcppSimdJson,
+  stringr,
+  stringi,
+  sf,
+  stats,
   tidyr,
   xml2,
   zip,
@@ -47,4 +48,4 @@ Suggests:
     rmarkdown,
     testthat
 VignetteBuilder: knitr
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

NAMESPACE

@@ -1,10 +1,16 @@
 # Generated by roxygen2: do not edit by hand
 
 export(ATOC_shapes)
+export(UK2GTFS_option_stopProcessingAtUid)
+export(UK2GTFS_option_treatDatesAsInt)
+export(UK2GTFS_option_updateCachedDataOnLibaryLoad)
+export(as_data_table_naptan_stop_area)
+export(as_data_table_naptan_stop_point)
 export(atoc2gtfs)
 export(dl_example_file)
 export(get_bank_holidays)
 export(get_naptan)
+export(get_naptan_xml_doc)
 export(gtfs_clean)
 export(gtfs_clip)
 export(gtfs_compress)
@@ -32,7 +38,12 @@ export(importTSI)
 export(load_data)
 export(nptdr2gtfs)
 export(nr2gtfs)
+export(nrdp_fares)
+export(nrdp_routing)
+export(nrdp_timetable)
 export(station2stops)
 export(transxchange2gtfs)
 export(transxchange_import)
 export(update_data)
+import(data.table)
+importFrom(data.table,":=")

R/RailDataPortal.R

@@ -0,0 +1,129 @@
+nrdp_authenticate = function(username = Sys.getenv("NRDP_username"),
+                             password = Sys.getenv("NRDP_password")){
+
+  # Make the POST request
+  form_data <- list(
+    username = username,
+    password = password
+  )
+
+  response <- httr::POST(
+    url =  'https://opendata.nationalrail.co.uk/authenticate',
+    body = form_data,
+    encode = "form"
+  )
+
+  json = httr::content(response)
+
+  return(json)
+
+
+}
+
+
+#' Download Timetable from National Rail Data Portal
+#'
+#' Downloads ATOC CIF timetables from https://opendata.nationalrail.co.uk
+#' @param destfile Detestation and name of the zip file
+#' @param username your username
+#' @param password your password
+#' @param url URL of data source
+#' @export
+
+nrdp_timetable = function(destfile = "timetable.zip",
+                          username = Sys.getenv("NRDP_username"),
+                          password = Sys.getenv("NRDP_password"),
+                          url = "https://opendata.nationalrail.co.uk/api/staticfeeds/3.0/timetable"){
+
+
+
+  token = nrdp_authenticate(username, password)
+
+  response <- httr::GET(
+    url =  url,
+    httr::add_headers(`X-Auth-Token` = token$token)
+  )
+
+  # Check if the request was successful
+  if (httr::status_code(response) == 200) {
+    # Write the content of the response to a file
+    writeBin(httr::content(response, "raw"), destfile)
+    cat("File downloaded successfully to", destfile)
+  } else {
+    cat("Failed to download the file. Status code:", httr::status_code(response))
+  }
+
+
+}
+
+#' Download Fares  from National Rail Data Portal
+#'
+#' Downloads fares from https://opendata.nationalrail.co.uk
+#' @param destfile Detestation and name of the zip file
+#' @param username your username
+#' @param password your password
+#' @param url URL of data source
+#' @export
+#'
+nrdp_fares = function(destfile = "fares.zip",
+                          username = Sys.getenv("NRDP_username"),
+                          password = Sys.getenv("NRDP_password"),
+                          url = "https://opendata.nationalrail.co.uk/api/staticfeeds/2.0/fares"){
+
+
+
+  token = nrdp_authenticate(username, password)
+
+  response <- httr::GET(
+    url =  url,
+    httr::add_headers(`X-Auth-Token` = token$token)
+  )
+
+  # Check if the request was successful
+  if (httr::status_code(response) == 200) {
+    # Write the content of the response to a file
+    writeBin(httr::content(response, "raw"), destfile)
+    cat("File downloaded successfully to", destfile)
+  } else {
+    cat("Failed to download the file. Status code:", httr::status_code(response))
+  }
+
+
+}
+
+
+#' Download routing  from National Rail Data Portal
+#'
+#' Downloads routing from https://opendata.nationalrail.co.uk
+#' @param destfile Detestation and name of the zip file
+#' @param username your username
+#' @param password your password
+#' @param url URL of data source
+#' @export
+#'
+nrdp_routing = function(destfile = "routeing.zip",
+                      username = Sys.getenv("NRDP_username"),
+                      password = Sys.getenv("NRDP_password"),
+                      url = "https://opendata.nationalrail.co.uk/api/staticfeeds/2.0/routeing"){
+
+
+
+  token = nrdp_authenticate(username, password)
+
+  response <- httr::GET(
+    url =  url,
+    httr::add_headers(`X-Auth-Token` = token$token)
+  )
+
+  # Check if the request was successful
+  if (httr::status_code(response) == 200) {
+    # Write the content of the response to a file
+    writeBin(httr::content(response, "raw"), destfile)
+    cat("File downloaded successfully to", destfile)
+  } else {
+    cat("Failed to download the file. Status code:", httr::status_code(response))
+  }
+
+
+}
+

R/UK2GTFS-package.R

@@ -0,0 +1,8 @@
+#' @keywords internal
+"_PACKAGE"
+
+## usethis namespace: start
+#' @import data.table
+#' @importFrom data.table ":="
+## usethis namespace: end
+NULL

R/atoc.R

@@ -10,8 +10,10 @@
 #' @param agency where to get agency.txt (see details)
 #' @param shapes Logical, should shapes.txt be generated (default FALSE)
 #' @param transfers Logical, should transfers.txt be generated (default TRUE)
-#' @param missing_tiplocs Logical, if locations = tiplocs, then will check for
+#' @param missing_tiplocs Logical, if true will check for
 #'   any missing tiplocs against the main file and add them.(default TRUE)
+#' @param working_timetable Logical, should WTT times be used instead of public times (default FALSE)
+#' @param public_only Logical, only return calls/services that are for public passenger pickup/set down (default TRUE)
 #' @family main
 #'
 #' @details Locations
@@ -44,22 +46,9 @@ atoc2gtfs <- function(path_in,
                       agency = "atoc_agency",
                       shapes = FALSE,
                       transfers = TRUE,
-                      missing_tiplocs = TRUE) {
-
-  if(inherits(locations,"character")){
-    if(locations == "tiplocs"){
-      load_data("tiplocs")
-      locations = tiplocs
-    }
-  }
-
-  if(inherits(agency,"character")){
-    if(agency == "atoc_agency"){
-      load_data("atoc_agency")
-      agency = atoc_agency
-    }
-  }
-
+                      missing_tiplocs = TRUE,
+                      working_timetable = FALSE,
+                      public_only = TRUE) {
   # Checkmates
   checkmate::assert_character(path_in, len = 1)
   checkmate::assert_file_exists(path_in)
@@ -73,6 +62,14 @@ atoc2gtfs <- function(path_in,
       " This will take some time, make sure you use 'ncores' to enable multi-core processing"
     ))
   }
+
+  agency = getCachedAgencyData( agency )
+
+  if ( !inherits(locations, "character") || "file"!=locations )
+  {
+    stops_sf = getCachedLocationData( locations )
+  }
+
   # Is input a zip or a folder
   if (grepl(".zip", path_in)) {
     # Unzip
@@ -110,75 +107,42 @@ atoc2gtfs <- function(path_in,
       file = files[grepl(".mca", files)],
       silent = silent,
       ncores = 1,
-      full_import = TRUE
+      full_import = TRUE,
+      working_timetable = working_timetable,
+      public_only = public_only
   )
 
 
-  # Get the Station Locations
-  # Are locations provided?
-  if ("sf" %in% class(locations)) {
-    stops_sf <- cbind(locations, sf::st_coordinates(locations))
-    stops_sf <- as.data.frame(stops_sf)
-    stops_sf <- stops_sf[, c(
-      "stop_id", "stop_code", "stop_name",
-      "Y", "X"
-    )]
-    names(stops_sf) <- c(
-      "stop_id", "stop_code", "stop_name",
-      "stop_lat", "stop_lon"
-    )
-    stops_sf$stop_lat <- round(stops_sf$stop_lat, 5)
-    stops_sf$stop_lon <- round(stops_sf$stop_lon, 5)
-  }
-
   # Should the file be checked
-  check_file <- FALSE
-  if("sf" %in% class(locations) & missing_tiplocs){
-    check_file <- TRUE
-  }
-
-  if ("character" %in% class(locations)) {
-    if(locations == "file"){
-      check_file <- TRUE
-    }
-  }
-
-  if (check_file) {
+  if ( TRUE==missing_tiplocs ||
+       ( inherits(locations, "character") && "file"==locations ) )
+  {
     msn <- importMSN(files[grepl(".msn", files)], silent = silent)
     station <- msn[[1]]
     TI <- mca[["TI"]]
     stops.list <- station2stops(station = station, TI = TI)
     stops_file <- stops.list[["stops"]]
     rm(msn,TI,stops.list)
-  }
 
-  # Was a csv provided
-  if ("character" %in% class(locations)) {
-    if(locations != "file"){
-      checkmate::check_file_exists(locations)
-      stops_csv <- utils::read.csv(locations, stringsAsFactors = FALSE)
+    if( FALSE==missing_tiplocs || !exists("stops_sf") )
+    {
+      stops <- stops_file
     }
-  }
-
-  # Chose Correct stops
-  if(exists("stops_csv")){
-    stops <- stops_csv
-  } else if(exists("stops_sf")){
-    if(missing_tiplocs == TRUE){
+    else
+    {
       # Combine
       stops_missing <- stops_file[!stops_file$stop_id %in% stops_sf$stop_id,]
       if(nrow(stops_missing) > 0){
-        warning("Adding ",nrow(stops_missing)," missing tiplocs, these may have unreliable location data")
+        message("Adding ",nrow(stops_missing)," missing tiplocs, these may have unreliable location data")
         stops <- rbind(stops_sf, stops_missing)
       } else {
         stops <- stops_sf
       }
-
-    } else {
-      stops <- stops_sf
     }
-  } else if(exists("stops_file")){
-    stops <- stops_file
+  }
+  else
+  {
+    stops <- stops_sf
   }
 
 
@@ -203,17 +167,23 @@ atoc2gtfs <- function(path_in,
   # remove any unused stops
   stops <- stops[stops$stop_id %in% stop_times$stop_id, ]
 
+  if ( nrow(stops)<=0 )
+  {
+    stop("Could not match any stops in input data to stop database.")
+  }
+
+
   # Main Timetable Build
   timetables <- schedule2routes(
     stop_times = stop_times,
     stops = stops,
     schedule = schedule,
     silent = silent,
-    ncores = ncores
+    ncores = ncores,
+    public_only = public_only
   )
   rm(schedule)
   gc()
-  # load("data/atoc_agency.RData")
 
   # TODO: check for stop_times that are not valid stops