Oo tfwm performance

R/gtfs_read.R

@@ -16,11 +16,11 @@ gtfs_read <- function(path){
   files <- list.files(tmp_folder, pattern = ".txt")
 
   gtfs <- list()
-  message_log <- c("Unable to find optional files: ")
 
   if(checkmate::test_file_exists(file.path(tmp_folder,"agency.txt"))){
     gtfs$agency <- readr::read_csv(file.path(tmp_folder,"agency.txt"),
-                                   col_types = readr::cols(agency_id = readr::col_character()),
+                                   col_types = readr::cols(agency_id = readr::col_character(),
+                                                           agency_noc = readr::col_character()),
                                    show_col_types = FALSE,
                                    lazy = FALSE)
   } else {
@@ -33,7 +33,11 @@ gtfs_read <- function(path){
                                                           stop_code = readr::col_character(),
                                                           stop_name = readr::col_character(),
                                                           stop_lat = readr::col_number(),
-                                                          stop_lon = readr::col_number()),
+                                                          stop_lon = readr::col_number(),
+                                                          wheelchair_boarding = readr::col_integer(), #enum value 2 is valid but rarely seen outside the spec document
+                                                          location_type = readr::col_integer(),
+                                                          parent_station = readr::col_character(),
+                                                          platform_code = readr::col_character()),
 
 
                                   lazy = FALSE, show_col_types = FALSE)
@@ -46,7 +50,8 @@ gtfs_read <- function(path){
                                    col_types = readr::cols(route_id = readr::col_character(),
                                                            agency_id = readr::col_character(),
                                                            route_short_name = readr::col_character(),
-                                                           route_long_name = readr::col_character()),
+                                                           route_long_name = readr::col_character(),
+                                                           route_type = readr::col_integer()),
                                    show_col_types = FALSE,
                                    lazy = FALSE)
   } else {
@@ -56,7 +61,12 @@ gtfs_read <- function(path){
   if(checkmate::test_file_exists(file.path(tmp_folder,"trips.txt"))){
     gtfs$trips <- readr::read_csv(file.path(tmp_folder,"trips.txt"),
                                   col_types = readr::cols(trip_id = readr::col_character(),
-                                                          route_id = readr::col_character()),
+                                                          route_id = readr::col_character(),
+                                                          service_id = readr::col_character(),
+                                                          block_id = readr::col_character(),
+                                                          shape_id = readr::col_character(),
+                                                          wheelchair_accessible = readr::col_integer() #enum value 2 is valid but rarely seen outside the spec document
+                                                          ),
                                   show_col_types = FALSE,
                                   lazy = FALSE)
   } else {
@@ -66,8 +76,14 @@ gtfs_read <- function(path){
   if(checkmate::test_file_exists(file.path(tmp_folder,"stop_times.txt"))){
     gtfs$stop_times <- readr::read_csv(file.path(tmp_folder,"stop_times.txt"),
                                        col_types = readr::cols(trip_id = readr::col_character(),
+                                                               stop_id = readr::col_character(),
+                                                               stop_sequence = readr::col_integer(),
                                                                departure_time = readr::col_character(),
-                                                               arrival_time = readr::col_character()),
+                                                               arrival_time = readr::col_character(),
+                                                               shape_dist_traveled = readr::col_number(),
+                                                               timepoint = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                               pickup_type = readr::col_integer(),
+                                                               drop_off_type = readr::col_integer()),
                                        show_col_types = FALSE,
                                        lazy = FALSE)
     gtfs$stop_times$arrival_time <- lubridate::hms(gtfs$stop_times$arrival_time)
@@ -79,7 +95,15 @@ gtfs_read <- function(path){
 
   if(checkmate::test_file_exists(file.path(tmp_folder,"calendar.txt"))){
     gtfs$calendar <- readr::read_csv(file.path(tmp_folder,"calendar.txt"),
-                                     col_types = readr::cols(start_date = readr::col_date(format = "%Y%m%d"),
+                                     col_types = readr::cols(service_id = readr::col_character(),
+                                                             monday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             tuesday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             wednesday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             thursday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             friday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             saturday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             sunday = readr::col_integer(), #boolean but treat as integer so 0|1 written to file
+                                                             start_date = readr::col_date(format = "%Y%m%d"),
                                                              end_date = readr::col_date(format = "%Y%m%d")),
                                      show_col_types = FALSE,
                                      lazy = FALSE)
@@ -90,52 +114,42 @@ gtfs_read <- function(path){
 
   if(checkmate::test_file_exists(file.path(tmp_folder,"calendar_dates.txt"))){
     gtfs$calendar_dates <- readr::read_csv(file.path(tmp_folder,"calendar_dates.txt"),
-                                           col_types = readr::cols(date = readr::col_date(format = "%Y%m%d")),
+                                           col_types = readr::cols(service_id = readr::col_character(),
+                                                                   date = readr::col_date(format = "%Y%m%d"),
+                                                                   exception_type = readr::col_integer()),
                                            show_col_types = FALSE,
                                            lazy = FALSE)
   } else {
     message("Unable to find conditionally required file: calendar_dates.txt")
   }
 
-  if(checkmate::test_file_exists(file.path(tmp_folder,"fare_attributes.txt"))){
-    gtfs$fare_attributes <- readr::read_csv(file.path(tmp_folder,"fare_attributes.txt"),
-                                            show_col_types = FALSE,
-                                            lazy = FALSE)
-  } else {
-    message_log <- c(message_log, "fare_attributes.txt")
-  }
-
-  if(checkmate::test_file_exists(file.path(tmp_folder,"fare_rules.txt"))){
-    gtfs$fare_rules <- readr::read_csv(file.path(tmp_folder,"fare_rules.txt"),
-                                       show_col_types = FALSE,
-                                       lazy = FALSE)
-  } else {
-    message_log <- c(message_log, "fare_rules.txt")
-  }
-
   if(checkmate::test_file_exists(file.path(tmp_folder,"shapes.txt"))){
     gtfs$shapes <- readr::read_csv(file.path(tmp_folder,"shapes.txt"),
+                                   col_types = readr::cols(shape_id = readr::col_character(),
+                                                           shape_pt_lat = readr::col_number(),
+                                                           shape_pt_lon = readr::col_number(),
+                                                           shape_pt_sequence = readr::col_integer(),
+                                                           shape_dist_traveled = readr::col_number()),
                                    show_col_types = FALSE,
                                    lazy = FALSE)
-  } else {
-    message_log <- c(message_log, "shapes.txt")
   }
 
-  if(checkmate::test_file_exists(file.path(tmp_folder,"transfers.txt"))){
-    gtfs$transfers <- readr::read_csv(file.path(tmp_folder,"transfers.txt"),
-                                      show_col_types = FALSE,
-                                      lazy = FALSE)
-  } else {
-    message_log <- c(message_log, "transfers.txt")
-  }
 
-  unlink(tmp_folder, recursive = TRUE)
+  #load any other tables in the .zip file
+  filenamesOnly <- tools::file_path_sans_ext(basename(files))
+  notLoadedFiles = setdiff(  filenamesOnly, names(gtfs) )
 
-
-  if(length(message_log) > 0){
-    message(paste(message_log, collapse = " "))
+  for (fileName in notLoadedFiles)
+  {
+    table <- readr::read_csv(file.path( tmp_folder, paste0( fileName, ".txt" ) ),
+                              show_col_types = FALSE,
+                              lazy = FALSE)
+    gtfs[[fileName]] <- table
   }
 
+  #remove temp directory
+  unlink(tmp_folder, recursive = TRUE)
+
   return(gtfs)
 }
 

R/gtfs_subset.R

@@ -36,7 +36,7 @@ gtfs_clip <- function(gtfs, bounds) {
   gtfs$stop_times <- gtfs$stop_times[gtfs$stop_times$stop_id %in% stops_inc, ]
   # Check for single stop trips
   n_stops <- table(gtfs$stop_times$trip_id)
-  single_stops <- as.integer(names(n_stops[n_stops == 1]))
+  single_stops <- names(n_stops[n_stops == 1])
   gtfs$stop_times <- gtfs$stop_times[!gtfs$stop_times$trip_id %in% single_stops, ]
 
   # Check for any unused stops

R/transxchange.R

@@ -208,11 +208,11 @@ transxchange2gtfs <- function(path_in,
 
   if(!silent){ message(paste0(Sys.time(), " Merging GTFS objects"))}
 
-  gtfs_merged <- try(gtfs_merge(gtfs_all, force = force_merge))
+  gtfs_merged <- try(gtfs_merge(gtfs_all, force=force_merge, quiet=silent))
 
   if (class(gtfs_merged) == "try-error") {
-    message("Merging failed, returing unmerged GFTS object for analysis")
-    return(gtfs_all)
+    warning("Merging failed, returing unmerged GFTS object for analysis")
+    return(gtfs_all) #this is not helpful - caller has no idea there was an error and ploughs on, causing strange errors much later on
   }
   return(gtfs_merged)
 }

R/transxchange_export.R

@@ -499,12 +499,12 @@ transxchange_export <- function(obj,
     calendar_dates <- data.frame(
       trip_id = character(),
       date = character(),
-      exception_type = character(),
+      exception_type = integer(),
       stringsAsFactors = FALSE
     )
     calendar_summary <- dplyr::group_by(calendar, start_date, end_date, DaysOfWeek)
   } else {
-    # remove calendar_dates for trips that have been competly removed
+    # remove calendar_dates for trips that have been competely removed
     calendar_dates <- calendar_dates[calendar_dates$trip_id %in% calendar$trip_id, ]
 
     calendar_summary <- dplyr::group_by(calendar, start_date, end_date, DaysOfWeek)

R/write_gtfs.R

@@ -1,6 +1,6 @@
 #' Write GTFS
 #'
-#' Takes a list of data frames represneting the GTFS fromat and saves them as GTFS
+#' Takes a list of data frames representing the GTFS format and saves them as GTFS
 #' Zip file.
 #'
 #' @param gtfs named list of data.frames
@@ -19,6 +19,7 @@ gtfs_write <- function(gtfs,
                        stripTab = TRUE,
                        stripNewline = TRUE,
                        quote = FALSE) {
+
   if (stripComma) {
     for (i in seq_len(length(gtfs))) {
       gtfs[[i]] <- stripCommas(gtfs[[i]])
@@ -33,7 +34,6 @@ gtfs_write <- function(gtfs,
 
 
   #Format Dates
-
   if(inherits(gtfs$calendar$start_date, "Date")){
     gtfs$calendar$start_date <- format(gtfs$calendar$start_date, "%Y%m%d")
   }
@@ -55,26 +55,32 @@ gtfs_write <- function(gtfs,
     gtfs$stop_times$departure_time <- period2gtfs(gtfs$stop_times$departure_time)
   }
 
+  if("frequencies" %in% names(gtfs))
+  {
+    if("difftime" %in% class(gtfs$frequencies$start_time)){
+      gtfs$frequencies$start_time <- format(gtfs$frequencies$start_time, format = "%H:%M:%S")
+    }
 
-  dir.create(paste0(tempdir(), "/gtfs_temp"))
-  data.table::fwrite(gtfs$calendar, paste0(tempdir(), "/gtfs_temp/calendar.txt"), row.names = FALSE, quote = quote)
-  if (nrow(gtfs$calendar_dates) > 0) {
-    data.table::fwrite(gtfs$calendar_dates, paste0(tempdir(), "/gtfs_temp/calendar_dates.txt"), row.names = FALSE, quote = quote)
-  }
-  data.table::fwrite(gtfs$routes, paste0(tempdir(), "/gtfs_temp/routes.txt"), row.names = FALSE, quote = quote)
-  data.table::fwrite(gtfs$stop_times, paste0(tempdir(), "/gtfs_temp/stop_times.txt"), row.names = FALSE, quote = quote)
-  data.table::fwrite(gtfs$trips, paste0(tempdir(), "/gtfs_temp/trips.txt"), row.names = FALSE, quote = quote)
-  data.table::fwrite(gtfs$stops, paste0(tempdir(), "/gtfs_temp/stops.txt"), row.names = FALSE, quote = quote)
-  data.table::fwrite(gtfs$agency, paste0(tempdir(), "/gtfs_temp/agency.txt"), row.names = FALSE, quote = quote)
-  if ("transfers" %in% names(gtfs)) {
-    data.table::fwrite(gtfs$transfers, paste0(tempdir(), "/gtfs_temp/transfers.txt"), row.names = FALSE, quote = quote)
+    if("difftime" %in% class(gtfs$frequencies$end_time)){
+      gtfs$frequencies$end_time <- format(gtfs$frequencies$end_time, format = "%H:%M:%S")
+    }
   }
-  if ("shapes" %in% names(gtfs)) {
-    data.table::fwrite(gtfs$shapes, paste0(tempdir(), "/gtfs_temp/shapes.txt"), row.names = FALSE, quote = quote)
+
+  dir.create(paste0(tempdir(), "/gtfs_temp"))
+
+  for ( tableName in names(gtfs) )
+  {
+    table <- gtfs[[tableName]]
+
+    if ( !is.null(table) & nrow(table) > 0 )
+    {
+      data.table::fwrite(table, file.path(tempdir(), "gtfs_temp", paste0(tableName, ".txt")), row.names = FALSE, quote = quote)
+    }
   }
+
   zip::zipr(paste0(folder, "/", name, ".zip"), list.files(paste0(tempdir(), "/gtfs_temp"), full.names = TRUE), recurse = FALSE)
+
   unlink(paste0(tempdir(), "/gtfs_temp"), recursive = TRUE)
-  message(paste0(folder, "/", name, ".zip"))
 }
 
 
@@ -126,9 +132,11 @@ stripTabs <- function(df, stripNewline) {
 
 
 #' Convert Period to GTFS timestamps
+#' When writing a 400mb (zipped) file, we spend nearly 4 minutes in this fn(), about 10x longer than writing the files to the filesystem.
+#' profiler reports this being mostly nchar(), so we optimise down to one sprintf which reduces the time to 1 minute
+#' .format() is about 7x slower than sprintf()
 #'
-#'
-#' @param x peridos
+#' @param x periods
 #' @noRd
 #'
 period2gtfs <- function(x) {
@@ -139,14 +147,6 @@ period2gtfs <- function(x) {
     stop("Days detected in period objects, incorectly formatted period object")
   }
 
-  hrs <- as.character(lubridate::hour(x))
-  min <- as.character(lubridate::minute(x))
-  sec <- as.character(lubridate::second(x))
-
-  hrs <- ifelse(nchar(hrs) == 1,paste0("0",hrs), hrs)
-  min <- ifelse(nchar(min) == 1,paste0("0",min), min)
-  sec <- ifelse(nchar(sec) == 1,paste0("0",sec), sec)
-
-  return(paste0(hrs,":",min,":",sec))
+  return( sprintf("%02d:%02d:%02d", lubridate::hour(x), lubridate::minute(x), lubridate::second(x)) )
 }
 

tests/testthat/test_transxchange.R

@@ -26,7 +26,8 @@ test_that("test transxchange2gtfs singlecore", {
                             naptan = naptan,
                             ncores = 1,
                             try_mode = FALSE,
-                            force_merge = TRUE)
+                            force_merge = TRUE,
+                            silent = FALSE)
   gtfs_write(gtfs,folder = file_path, name = "txc_gtfs2")
   expect_true(file.exists(file.path(file_path,"txc_gtfs2.zip")))
 
@@ -40,7 +41,8 @@ if(.Platform$OS.type == "unix") {
                               naptan = naptan,
                               ncores = 2,
                               try_mode = FALSE,
-                              force_merge = TRUE)
+                              force_merge = TRUE,
+                              silent = FALSE)
     gtfs_write(gtfs,folder = file_path, name = "txc_gtfs")
     expect_true(file.exists(file.path(file_path,"txc_gtfs.zip")))