tests/testthat/test-get_route_frequency.R

In gtfstools: General Transit Feed Specification (GTFS) Editing and Analysing Tools

spo_path <- system.file("extdata/spo_gtfs.zip", package = "gtfstools")
ggl_path <- system.file("extdata/ggl_gtfs.zip", package = "gtfstools")
gtfs <- read_gtfs(spo_path)
ggl_gtfs <- read_gtfs(ggl_path)

tester <- function(gtfs = get("gtfs", envir = parent.frame()),
                   route_id = NULL,
                   from = "07:00:00",
                   to = "09:00:00") {
  get_route_frequency(gtfs, route_id, from, to)
}

# mixed feed built from spo: trips listed in 'frequencies' and scheduled trips
# (two trips have their 'frequencies' entries removed), one scheduled trip with
# blank times, trips with NA direction_id and two service_ids. the trip with
# blank times must not be listed in 'frequencies', otherwise
# frequencies_to_stop_times() raises an error when building the expected
# results below

mixed_gtfs <- read_gtfs(spo_path)
scheduled_trips <- c("CPTM L07-1", "2002-10-0")
mixed_gtfs$frequencies <- mixed_gtfs$frequencies[
  ! trip_id %chin% scheduled_trips
]

blank_trip <- mixed_gtfs$trips[trip_id == "CPTM L07-1"]
blank_trip[, trip_id := "blank_trip"]
mixed_gtfs$trips <- rbind(mixed_gtfs$trips, blank_trip)

blank_stop_times <- mixed_gtfs$stop_times[trip_id == "CPTM L07-1"]
blank_stop_times[
  ,
  `:=`(trip_id = "blank_trip", arrival_time = "", departure_time = "")
]
mixed_gtfs$stop_times <- rbind(mixed_gtfs$stop_times, blank_stop_times)

mixed_gtfs$trips[
  trip_id %chin% c("CPTM L08-1", "2105-10-1"),
  direction_id := NA
]

# expected number of departures by route, direction and service, based on the
# first departure of each trip in the stop_times table generated by
# frequencies_to_stop_times()

expanded_gtfs <- frequencies_to_stop_times(mixed_gtfs)
expanded_departures <- expanded_gtfs$stop_times[
  ,
  .(departure_secs = string_to_seconds(departure_time)),
  by = trip_id
]
expanded_departures <- expanded_departures[
  ,
  .(
    departure_secs = if (all(is.na(departure_secs))) {
      NA_integer_
    } else {
      min(departure_secs, na.rm = TRUE)
    }
  ),
  by = trip_id
]
expanded_departures <- expanded_gtfs$trips[
  expanded_departures,
  on = "trip_id"
]

expected_frequency <- function(from, to) {
  from_secs <- string_to_seconds(from)
  to_secs <- string_to_seconds(to)

  expected <- expanded_departures[
    departure_secs >= from_secs & departure_secs < to_secs,
    .(departures = .N),
    keyby = .(route_id, direction_id, service_id)
  ]
  expected[, mean_headway := (to_secs - from_secs) / departures / 60]

  return(expected[])
}

# trips listed in 'frequencies' are counted even if they are not listed in
# 'stop_times'. this trip is removed from 'stop_times' only after creating the
# expected results, so they still include it

mixed_gtfs$stop_times <- mixed_gtfs$stop_times[trip_id != "CPTM L08-0"]


# tests -------------------------------------------------------------------


test_that("raises errors due to incorrect input types/value", {
  no_class_gtfs <- structure(gtfs, class = NULL)
  expect_error(tester(no_class_gtfs))
  expect_error(tester(route_id = as.factor("CPTM L07")))
  expect_error(tester(route_id = NA))
  expect_error(tester(from = 7))
  expect_error(tester(from = "7:00:00"))
  expect_error(tester(from = c("07:00:00", "08:00:00")))
  expect_error(tester(to = "09:60:00"))
  expect_error(
    tester(from = "09:00:00", to = "07:00:00"),
    class = "gtfstools_invalid_time_of_day"
  )
  expect_error(
    tester(from = "09:00:00", to = "09:00:00"),
    class = "gtfstools_invalid_time_of_day"
  )
})

test_that("raises errors if gtfs doesn't have required files/fields", {
  no_trips_gtfs <- copy_gtfs_without_file(gtfs, "trips")
  no_stop_times_gtfs <- copy_gtfs_without_file(gtfs, "stop_times")

  no_trp_routeid_gtfs <- copy_gtfs_without_field(gtfs, "trips", "route_id")
  no_trp_serviceid_gtfs <- copy_gtfs_without_field(gtfs, "trips", "service_id")
  no_st_deptime_gtfs <- copy_gtfs_without_field(
    gtfs,
    "stop_times",
    "departure_time"
  )
  no_frq_headway_gtfs <- copy_gtfs_without_field(
    gtfs,
    "frequencies",
    "headway_secs"
  )

  wrong_routeid_gtfs <- copy_gtfs_diff_field_class(
    gtfs,
    "trips",
    "route_id",
    "factor"
  )
  wrong_deptime_gtfs <- copy_gtfs_diff_field_class(
    gtfs,
    "stop_times",
    "departure_time",
    "factor"
  )
  wrong_headway_gtfs <- copy_gtfs_diff_field_class(
    gtfs,
    "frequencies",
    "headway_secs",
    "character"
  )

  expect_error(tester(no_trips_gtfs), class = "missing_required_file")
  expect_error(tester(no_stop_times_gtfs), class = "missing_required_file")
  expect_error(tester(no_trp_routeid_gtfs), class = "missing_required_field")
  expect_error(tester(no_trp_serviceid_gtfs), class = "missing_required_field")
  expect_error(tester(no_st_deptime_gtfs), class = "missing_required_field")
  expect_error(tester(no_frq_headway_gtfs), class = "missing_required_field")
  expect_error(tester(wrong_routeid_gtfs), class = "wrong_class_field")
  expect_error(tester(wrong_deptime_gtfs), class = "wrong_class_field")
  expect_error(tester(wrong_headway_gtfs), class = "wrong_class_field")
})

test_that("raises errors if 'frequencies' has invalid entries", {
  invalid_gtfs <- read_gtfs(spo_path)
  invalid_gtfs$frequencies[trip_id == "CPTM L07-0", headway_secs := 0L]

  expect_error(tester(invalid_gtfs), class = "gtfstools_invalid_frequencies")

  # only the entries of the specified routes are checked

  expect_s3_class(tester(invalid_gtfs, route_id = "CPTM L08"), "data.table")
})

test_that("raises warnings if a non_existent route_id is given", {
  expect_warning(
    tester(route_id = c("CPTM L07", "ola")),
    class = "gtfstools_invalid_route_id"
  )
  expect_warning(tester(route_id = "ola"), class = "gtfstools_invalid_route_id")
})

test_that("outputs a data.table with adequate columns' classes", {
  check_output <- function(frequency, direction = TRUE) {
    expected_cols <- c(
      "route_id",
      if (direction) "direction_id",
      "service_id",
      "departures",
      "mean_headway"
    )
    expect_s3_class(frequency, "data.table")
    expect_identical(names(frequency), expected_cols)
    expect_type(frequency$route_id, "character")
    expect_type(frequency$service_id, "character")
    expect_type(frequency$departures, "integer")
    expect_type(frequency$mean_headway, "double")
    if (direction) expect_type(frequency$direction_id, "integer")
  }

  check_output(tester())
  check_output(tester(route_id = character(0)))
  expect_warning(frequency <- tester(route_id = "ola"))
  check_output(frequency)

  # direction_id is not included if it's not present in 'trips'

  check_output(tester(ggl_gtfs, from = "00:00:00", to = "30:00:00"), FALSE)
})

test_that("calculates the frequency of the correct route_ids", {
  frequency <- tester()
  expect_true(all(gtfs$trips$route_id %chin% frequency$route_id))

  frequency <- tester(route_id = c("CPTM L07", "2002-10"))
  expect_setequal(frequency$route_id, c("CPTM L07", "2002-10"))
})

test_that("calculates frequency correctly in a mixed feed", {
  expect_equal(
    tester(mixed_gtfs, from = "07:00:00", to = "09:00:00"),
    expected_frequency("07:00:00", "09:00:00")
  )
  expect_equal(
    tester(mixed_gtfs, from = "00:00:00", to = "30:00:00"),
    expected_frequency("00:00:00", "30:00:00")
  )

  # the window includes departures at 'from', but not at 'to'

  expect_equal(
    tester(mixed_gtfs, "CPTM L07", from = "07:00:00", to = "07:06:00"),
    data.table::data.table(
      route_id = "CPTM L07",
      direction_id = 0L,
      service_id = "USD",
      departures = 1L,
      mean_headway = 6,
      key = c("route_id", "direction_id", "service_id")
    )
  )
})

test_that("counts frequencies departures correctly", {
  # entries generate departures until (but not including) their end_time, so
  # the adjoining entries below don't both generate the 06:00:00 departure and
  # there's no departure at 07:00:00. an entry with equal start and end times
  # generates a single departure. departures: 05:00, 05:30, 06:00, 06:30, 08:00

  freq_gtfs <- read_gtfs(spo_path)
  freq_gtfs$frequencies <- data.table::data.table(
    trip_id = "CPTM L07-0",
    start_time = c("05:00:00", "06:00:00", "08:00:00"),
    end_time = c("06:00:00", "07:00:00", "08:00:00"),
    headway_secs = c(1800L, 1800L, 0L)
  )

  frequency <- tester(freq_gtfs, "CPTM L07", from = "05:00:00", to = "09:00:00")
  expect_identical(frequency[direction_id == 0]$departures, 5L)

  frequency <- tester(freq_gtfs, "CPTM L07", from = "05:00:00", to = "06:00:00")
  expect_identical(frequency[direction_id == 0]$departures, 2L)

  frequency <- tester(freq_gtfs, "CPTM L07", from = "06:00:00", to = "07:00:00")
  expect_identical(frequency[direction_id == 0]$departures, 2L)

  frequency <- tester(freq_gtfs, "CPTM L07", from = "07:00:00", to = "08:00:00")
  expect_false(any(frequency$direction_id == 0))
})

test_that("works with feeds without 'frequencies'", {
  # ber doesn't have a 'frequencies' table, so each trip departs once, at the
  # earliest departure time listed in 'stop_times'

  ber_gtfs <- read_gtfs(
    system.file("extdata/ber_gtfs.zip", package = "gtfstools")
  )
  ber_departures <- ber_gtfs$stop_times[
    ,
    .(departure_secs = min(string_to_seconds(departure_time), na.rm = TRUE)),
    by = trip_id
  ]
  ber_departures <- ber_gtfs$trips[ber_departures, on = "trip_id"]
  expected <- ber_departures[
    departure_secs >= 6 * 3600 & departure_secs < 10 * 3600,
    .(departures = .N),
    keyby = .(route_id, direction_id, service_id)
  ]
  expected[, mean_headway := 240 / departures]

  expect_equal(tester(ber_gtfs, from = "06:00:00", to = "10:00:00"), expected)

  # and when 'frequencies' is removed from a feed that has it

  no_frequencies_gtfs <- copy_gtfs_without_file(gtfs, "frequencies")
  frequency <- tester(no_frequencies_gtfs, "CPTM L07", "00:00:00", "30:00:00")
  expect_identical(frequency$departures, c(1L, 1L))
})

test_that("counts departures after midnight", {
  # ggl's trip departs every 7 minutes from 20:30:00 to 28:00:00, so 10 times
  # between 24:00:00 (included) and 25:10:00 (not included)

  ggl_frequency <- tester(ggl_gtfs, from = "24:00:00", to = "25:10:00")
  expect_identical(ggl_frequency$departures, 10L)
  expect_equal(ggl_frequency$mean_headway, 7)
})

test_that("doesn't change given gtfs", {
  original_gtfs <- read_gtfs(spo_path)
  gtfs <- read_gtfs(spo_path)
  expect_identical(original_gtfs, gtfs)

  frequency <- tester(gtfs)
  expect_equal(original_gtfs, gtfs, ignore_attr = TRUE)

  # also when it already contains auxiliary '_secs' columns

  original_gtfs <- convert_time_to_seconds(read_gtfs(spo_path))
  gtfs <- convert_time_to_seconds(read_gtfs(spo_path))

  frequency <- tester(gtfs)
  expect_equal(original_gtfs, gtfs, ignore_attr = TRUE)
})