tests/testthat/test-time.R

In r-transit/tidytransit: Read, Validate, Analyze, and Map GTFS Feeds

create_empty_gtfs_obj <- function() {
  g <- list(agency = data.frame())
  gtfsio::new_gtfs(g)
}

test_that("convert_char_to_hms() works with valid data", {
  gtest <- create_empty_gtfs_obj()
  gtest$stop_times <- data.table::data.table(
    arrival_time = c("08:00:00", "14:00:00", "26:10:00"),
    departure_time = c("08:00:10", "14:00:20", "26:10:30"))
  gtest$frequencies = data.table::data.table(
    start_time = c("06:00:00"),
    end_time = c("12:00:00")
  )

  gtest <- convert_char_to_hms(gtest)
  
  expect_s3_class(gtest$stop_times$arrival_time, "hms")
  expect_s3_class(gtest$stop_times$departure_time, "hms")
  expect_false(is.na(gtest$stop_times$arrival_time[3]))
  expect_equal(gtest$stop_times$departure_time[3], 
               hms::hms(26 * 3600 + 10 * 60 + 30))
  
  expect_s3_class(gtest$frequencies$start_time, "hms")
  expect_s3_class(gtest$frequencies$end_time, "hms")
})

test_that("set_dates_services() uses the right dates", {
  gtest <- create_empty_gtfs_obj()
  gtest$calendar <- dplyr::tibble(
    service_id = "s1",
    monday = 1,
    tuesday = 0,
    wednesday = 1,
    thursday = 0,
    friday = 0,
    saturday = 0,
    sunday = 0,
    start_date = as.Date("2018-01-01"), # monday
    end_date = as.Date("2018-01-31")) # wednesday

  set_dates_services(gtest)
  
  date_service <- set_dates_services(gtest)$.$dates_services
  
  expect_true(as.Date("2018-01-01") %in% date_service$date)
  expect_false(as.Date("2018-01-02") %in% date_service$date)
  expect_true(as.Date("2018-01-31") %in% date_service$date)
})

test_that("set_dates_services() works with additions and exceptions", { 
  gtest <- create_empty_gtfs_obj()
  gtest$calendar <- dplyr::tibble(
    service_id = c("wdays", "wend"),
    monday = c(1, 0),
    tuesday = c(1, 0),
    wednesday = c(1, 0),
    thursday = c(1, 0),
    friday = c(1, 1),
    saturday = c(0, 1),
    sunday = c(0, 1),
    start_date = c(as.Date("2018-02-01"), 
                   as.Date("2018-04-01")),
    end_date = c(as.Date("2018-04-30"), 
                 as.Date("2018-04-30")))
  gtest$calendar_dates <- dplyr::tibble(
    service_id = c("wdays", "wend"),
    date = c(as.Date("2018-03-14"), as.Date("2018-02-26")),
    exception_type = c(2, 1)
  )
  
  date_service <- set_dates_services(gtest)$.$dates_services
  
  # exception
  mar14 <- date_service[
    date_service$date == as.Date("2018-06-13"),]
  expect_equal(nrow(mar14), 0)
  
  # addition
  feb26 <- date_service[
    date_service$date == as.Date("2018-02-26"),] # monday
  expect_equal(nrow(feb26), 2)
  
  # overlaps
  apr05 <- date_service[
    date_service$date == as.Date("2018-04-05"), ]
  expect_equal(apr05 %>% dplyr::group_by(date) %>% 
                 dplyr::count() %>% 
                 dplyr::pull(n), 1)
  apr06 <- date_service[
    date_service$date == as.Date("2018-04-06"), ] # friday
  expect_equal(apr06 %>% 
               dplyr::group_by(date) %>% 
               dplyr::count() %>% 
               dplyr::pull(n), 2)
  
  range <- date_service %>% 
    dplyr::group_by(service_id) %>% 
    dplyr::summarise(min = min(date), max = max(date))
  expect_equal(range[
    range$service_id == "wdays", "min"], 
    dplyr::tibble(min = as.Date("2018-02-01")))
  expect_equal(
    range[range$service_id == "wend", "max"], 
    dplyr::tibble(max = as.Date("2018-04-29")))
})

test_that("parse dates", {
  x = "20180429"
  y = .parse_gtfsio_date(x)
  expect_s3_class(y, "Date")
  z = .date_as_gtfsio_char(y)
  expect_equal(x, z)
})

test_that("set_dates_services w/o calendar", {
  gpath = system.file("extdata", "sample-feed-calendar_dates.zip", package = "tidytransit")
  gcal = read_gtfs(gpath)
  expect_equal(gcal$.$dates_services$date, as.Date(c("2007-01-01", "2007-06-06")))
})

test_that("interpolate stop_times", {
  st_seq = dplyr::as_tibble(rbind(
    data.frame(trip_id = "A", stop_sequence = 1:4, 
               arrival_time = hms::hms(c(NA,2,NA,10)*60),
               departure_time = hms::hms(c(0,2,NA,NA)*60)
               ),
    data.frame(trip_id = "B", stop_sequence = 1:3, 
               arrival_time = hms::hms(c(10,NA,20)*60),
               departure_time = hms::hms(c(10,NA,20)*60)
    ),
    data.frame(trip_id = "C", stop_sequence = 1:3, 
               arrival_time = hms::hms(c(0,1,2)*60),
               departure_time = hms::hms(c(0,1,2)*60)
    )
  ))
  
  st_shapes = st_seq
  st_shapes$shape_dist_traveled <- c(0,2,9,10, 0,0.1,3, 0,1,2)
  seq1 = interpolate_stop_times(st_seq)
  expect_equal(nrow(st_seq), nrow(seq1))
  expect_equal(as.numeric(seq1$departure_time[c(3,6)]), 60*c(6,15))
  shapes1 = interpolate_stop_times(st_shapes)
  expect_equal(as.numeric(shapes1$departure_time[c(3,6)]), 60*c(9, 10+0.1*((20-10)/3)))
  noshapes1 = interpolate_stop_times(st_shapes, use_shape_dist = FALSE)
  expect_equal(noshapes1$arrival_time, seq1$arrival_time)
  
  .index = !is.na(st_seq$arrival_time) & !is.na(st_seq$departure_time)
  expect_true(all(as.data.frame(st_seq)[.index,] == as.data.frame(seq1)[.index,]))  
  
  gtfs_duke2 = interpolate_stop_times(gtfs_duke)
  expect_equal(class(gtfs_duke2$stop_times), class(gtfs_duke$stop_times))
  expect_false(anyNA(gtfs_duke2$stop_times$arrival_time))
  expect_false(anyNA(gtfs_duke2$stop_times$departure_time))
})

test_that("approx_NA", {
  y = c(6,NA,10)
  expect_equal(approx_NA(y), c(6,8,10))
  expect_equal(approx_NA(y, c(6,9.5,10)), c(6,9.5,10))
})