tests/testthat/test-get_stop_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()),
                   stop_id = NULL,
                   by_route = FALSE,
                   from = "07:00:00",
                   to = "09:00:00") {
  get_stop_frequency(gtfs, stop_id, from, to, by_route)
}

# small hand-built feed, whose expected results are listed in the tests below:
# - "freq" is listed in 'frequencies' and departs at 06:00, 06:10, 06:20,
#   07:00 and 07:10, visiting A at +0 min, B at +5 min and C (its last stop) at
#   +10 min;
# - "loop" visits A twice (08:00 and 08:20), B with a blank time and ends at C;
# - "single" has a single stop, which is therefore its last stop;
# - "na_seq" visits B at 09:00, C at 09:10 (with an NA stop_sequence) and ends
#   at A;
# - "all_na_seq" has only NA stop_sequences, so it has no last stop: it visits
#   B at 09:30 and C at 09:40;
# - "orphan" is listed in 'stop_times', but not in 'trips'

hand_gtfs <- read_gtfs(spo_path)
hand_gtfs$trips <- data.table::data.table(
  trip_id = c("freq", "loop", "single", "na_seq", "all_na_seq"),
  route_id = c("r1", "r2", "r2", "r3", "r3"),
  service_id = "s",
  direction_id = c(0L, 0L, 1L, 0L, 0L)
)
hand_gtfs$stop_times <- data.table::data.table(
  trip_id = c(
    rep("freq", 3),
    rep("loop", 4),
    "single",
    rep("na_seq", 3),
    rep("all_na_seq", 2),
    rep("orphan", 2)
  ),
  stop_id = c(
    "A", "B", "C",
    "A", "B", "A", "C",
    "A",
    "B", "C", "A",
    "B", "C",
    "A", "B"
  ),
  stop_sequence = c(1:3, 1:4, 1L, 1L, NA, 3L, NA, NA, 1:2),
  departure_time = c(
    "10:00:00", "10:05:00", "10:10:00",
    "08:00:00", "", "08:20:00", "08:30:00",
    "08:00:00",
    "09:00:00", "09:10:00", "09:20:00",
    "09:30:00", "09:40:00",
    "08:00:00", "08:10:00"
  )
)
hand_gtfs$stop_times[, arrival_time := departure_time]
hand_gtfs$frequencies <- data.table::data.table(
  trip_id = "freq",
  start_time = c("06:00:00", "07:00:00"),
  end_time = c("06:30:00", "07:20:00"),
  headway_secs = 600L
)

# 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

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, based on the stop_times table generated by
# frequencies_to_stop_times(), excluding the last stop of each trip and blank
# departure times

expanded_gtfs <- frequencies_to_stop_times(mixed_gtfs)
expanded_departures <- expanded_gtfs$stop_times[
  ,
  .(
    trip_id,
    stop_id,
    stop_sequence,
    departure_secs = string_to_seconds(departure_time)
  )
]
expanded_departures[, last_seq := max(stop_sequence), by = trip_id]
expanded_departures <- expanded_departures[
  stop_sequence != last_seq & !is.na(departure_secs)
]
expanded_departures <- expanded_gtfs$trips[
  expanded_departures,
  on = "trip_id",
  nomatch = NULL
]

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

  group_cols <- c("stop_id", "service_id")
  if (by_route) {
    group_cols <- c("stop_id", "route_id", "direction_id", "service_id")
  }

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

  return(expected[])
}


# 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(stop_id = as.factor("18848")))
  expect_error(tester(stop_id = NA))
  expect_error(tester(by_route = NA))
  expect_error(tester(by_route = c(TRUE, FALSE)))
  expect_error(tester(by_route = "TRUE"))
  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_stopid_gtfs <- copy_gtfs_without_field(gtfs, "stop_times", "stop_id")
  no_st_stopseq_gtfs <- copy_gtfs_without_field(
    gtfs,
    "stop_times",
    "stop_sequence"
  )
  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_stopseq_gtfs <- copy_gtfs_diff_field_class(
    gtfs,
    "stop_times",
    "stop_sequence",
    "character"
  )
  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_serviceid_gtfs), class = "missing_required_field")
  expect_error(tester(no_st_stopid_gtfs), class = "missing_required_field")
  expect_error(tester(no_st_stopseq_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_stopseq_gtfs), class = "wrong_class_field")
  expect_error(tester(wrong_headway_gtfs), class = "wrong_class_field")

  # route_id is only required when by_route = TRUE

  expect_s3_class(tester(no_trp_routeid_gtfs), "data.table")
  expect_s3_class(tester(wrong_routeid_gtfs), "data.table")
  expect_error(
    tester(no_trp_routeid_gtfs, by_route = TRUE),
    class = "missing_required_field"
  )
  expect_error(
    tester(wrong_routeid_gtfs, by_route = TRUE),
    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 trips that serve the specified stops are checked

  expect_s3_class(tester(invalid_gtfs, stop_id = "18848"), "data.table")
})

test_that("raises warnings if a non_existent stop_id is given", {
  expect_warning(
    tester(stop_id = c("18848", "ola")),
    class = "gtfstools_invalid_stop_id"
  )
  expect_warning(tester(stop_id = "ola"), class = "gtfstools_invalid_stop_id")
})

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

  for (by_route in c(FALSE, TRUE)) {
    check_output(tester(by_route = by_route), by_route)
    check_output(tester(stop_id = character(0), by_route = by_route), by_route)
    expect_warning(frequency <- tester(stop_id = "ola", by_route = by_route))
    check_output(frequency, by_route)
  }

  expect_identical(nrow(tester(stop_id = character(0))), 0L)

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

  ggl_frequency <- tester(
    ggl_gtfs,
    by_route = TRUE,
    from = "00:00:00",
    to = "30:00:00"
  )
  check_output(ggl_frequency, by_route = TRUE, direction = FALSE)
})

test_that("calculates the frequency of the correct stop_ids", {
  frequency <- tester(from = "00:00:00", to = "30:00:00")
  expect_true(all(frequency$stop_id %chin% gtfs$stop_times$stop_id))

  frequency <- tester(stop_id = c("18848", "18960"))
  expect_setequal(frequency$stop_id, c("18848", "18960"))
})

test_that("calculates frequency correctly in a hand-built feed", {
  expect_equal(
    tester(hand_gtfs, from = "06:00:00", to = "10:00:00"),
    data.table::data.table(
      stop_id = c("A", "B", "C"),
      service_id = "s",
      departures = c(7L, 7L, 2L),
      mean_headway = 240 / c(7, 7, 2),
      key = c("stop_id", "service_id")
    )
  )

  expect_equal(
    tester(hand_gtfs, by_route = TRUE, from = "06:00:00", to = "10:00:00"),
    data.table::data.table(
      stop_id = c("A", "A", "B", "B", "C"),
      route_id = c("r1", "r2", "r1", "r3", "r3"),
      direction_id = 0L,
      service_id = "s",
      departures = c(5L, 2L, 5L, 2L, 2L),
      mean_headway = 240 / c(5, 2, 5, 2, 2),
      key = c("stop_id", "route_id", "direction_id", "service_id")
    )
  )

  # the departures of trips listed in 'frequencies' are shifted from the trip's
  # first departure, even when its first stop is not specified: "freq" departs
  # from B at 06:05, 06:15 and 06:25

  frequency <- tester(hand_gtfs, "B", from = "06:01:00", to = "06:09:00")
  expect_identical(frequency$departures, 1L)

  frequency <- tester(hand_gtfs, "B", from = "06:00:00", to = "07:00:00")
  expect_identical(frequency$departures, 3L)

  # the last stop of a trip is never counted

  frequency <- tester(hand_gtfs, "C", from = "06:00:00", to = "09:05:00")
  expect_identical(nrow(frequency), 0L)

  # regression guard: the results don't depend on data.table's GForce
  # optimisation (without it, max() and min() of groups without non-missing
  # values return -Inf/Inf with a warning)

  old_optimize <- options(datatable.optimize = 0L)
  on.exit(options(old_optimize), add = TRUE)
  expect_identical(
    tester(
      hand_gtfs,
      by_route = TRUE,
      from = "06:00:00",
      to = "10:00:00"
    )$departures,
    c(5L, 2L, 5L, 2L, 2L)
  )
  expect_identical(
    tester(hand_gtfs, from = "06:00:00", to = "10:00:00")$departures,
    c(7L, 7L, 2L)
  )
})

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

test_that("the window includes departures at 'from', but not at 'to'", {
  frequency <- tester(hand_gtfs, "A", from = "08:00:00", to = "08:20:00")
  expect_identical(frequency$departures, 1L)

  frequency <- tester(hand_gtfs, "A", from = "08:00:00", to = "08:20:01")
  expect_identical(frequency$departures, 2L)
})

test_that("works with feeds without 'frequencies'", {
  # ber doesn't have a 'frequencies' table, so each stop_times entry is a
  # departure, except for the last stop of each trip

  ber_gtfs <- read_gtfs(
    system.file("extdata/ber_gtfs.zip", package = "gtfstools")
  )
  ber_departures <- ber_gtfs$stop_times[
    ,
    .(
      trip_id,
      stop_id,
      stop_sequence,
      departure_secs = string_to_seconds(departure_time)
    )
  ]
  ber_departures[, last_seq := max(stop_sequence), by = trip_id]
  ber_departures <- ber_departures[stop_sequence != last_seq]
  ber_departures <- ber_gtfs$trips[ber_departures, on = "trip_id"]
  expected <- ber_departures[
    departure_secs >= 6 * 3600 & departure_secs < 10 * 3600,
    .(departures = .N),
    keyby = .(stop_id, service_id)
  ]
  expected[, mean_headway := 240 / departures]

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

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), from both S1 and
  # S3. S6 is its last stop

  ggl_frequency <- tester(ggl_gtfs, from = "24:00:00", to = "25:10:00")
  expect_identical(ggl_frequency$stop_id, c("S1", "S3"))
  expect_identical(ggl_frequency$departures, c(10L, 10L))
  expect_equal(ggl_frequency$mean_headway, c(7, 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)
  frequency <- tester(gtfs, by_route = TRUE)
  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, stop_id = "18848")
  expect_equal(original_gtfs, gtfs, ignore_attr = TRUE)
})