tests/testthat/test-set_percentiles.R

In r5r: Rapid Realistic Routing with 'R5'

# if running manually, please run the following line first:
# source("tests/testthat/setup.R")

testthat::skip_on_cran()

tester <- function(percentiles) set_percentiles(r5r_core, percentiles)

test_that("input is correct", {
  expect_error(tester("1"))
  expect_error(tester(0))
  expect_error(tester(100))
  expect_error(tester(c(1, 2, 3, 4, 5, 6)))
  expect_error(tester(c(1, 1)))
  expect_error(tester(NA))
  expect_error(tester(Inf))
})

test_that("set_percentiles argument works in travel_time_matrix()", {
  basic_expr <- call(
    "travel_time_matrix",
    r5r_core,
    pois,
    pois,
    mode = c("TRANSIT", "WALK"),
    departure_datetime = departure_datetime,
    draws_per_minute = 1,
    time_window = 30,
    max_trip_duration = 60
  )

  one_percent_expr <- many_percent_expr <- basic_expr
  one_percent_expr$percentiles <- 50
  many_percent_expr$percentiles <- c(1, 50, 99)

  one_percent <- eval(one_percent_expr)
  one_percent[, c("from_id", "to_id") := NULL]
  expect_true(ncol(one_percent) == 1)
  expect_true(names(one_percent) == "travel_time_p50")
  expect_type(one_percent$travel_time_p50, "integer")

  many_percent <- eval(many_percent_expr)
  many_percent[, c("from_id", "to_id") := NULL]
  expect_true(ncol(many_percent) == 3)
  expect_identical(
    names(many_percent),
    paste0("travel_time_p", c("01", "50", "99"))
  )
  expect_type(many_percent$travel_time_p01, "integer")
  expect_type(many_percent$travel_time_p50, "integer")
  expect_type(many_percent$travel_time_p99, "integer")

  # travel time may be NA if less than x% of the trips between a pair can be
  # completed within max_trip_duration. the lowest percentile can't have any NAs
  # though

  expect_false(any(is.na(many_percent$travel_time_p01)))
  expect_true(any(is.na(many_percent$travel_time_p50)))
  expect_true(any(is.na(many_percent$travel_time_p99)))

  many_percent[is.na(travel_time_p50), travel_time_p50 := 1000]
  many_percent[is.na(travel_time_p99), travel_time_p99 := 1000]
  expect_true(all(many_percent$travel_time_p01 <= many_percent$travel_time_p50))
  expect_true(all(many_percent$travel_time_p50 <= many_percent$travel_time_p99))
})

test_that("set_percentiles argument works in accessibility()", {
  basic_expr <- call(
    "accessibility",
    r5r_core,
    points[1:30],
    points[1:30],
    mode = c("TRANSIT", "WALK"),
    departure_datetime = departure_datetime,
    opportunities_colnames = "population",
    decay_function = "step",
    cutoffs = 30,
    draws_per_minute = 1,
    time_window = 30,
    max_trip_duration = 60
  )

  one_percent_expr <- many_percent_expr <- basic_expr
  one_percent_expr$percentiles <- 50
  many_percent_expr$percentiles <- c(1, 50, 99)

  one_percent <- eval(one_percent_expr)
  expect_type(one_percent$percentile, "integer")
  expect_true(unique(one_percent$percentile) == 50)

  many_percent <- eval(many_percent_expr)
  expect_type(many_percent$percentile, "integer")
  expect_equal(unique(many_percent$percentile), c(1, 50, 99))

  many_percent <- data.table::dcast(
    many_percent,
    id ~ percentile,
    value.var = "accessibility"
  )
  data.table::setnames(
    many_percent,
    old = as.character(c(1, 50, 99)),
    new = paste0("access_", c(1, 50, 99))
  )
  expect_true(all(many_percent$access_1 >= many_percent$access_50))
  expect_true(all(many_percent$access_50 >= many_percent$access_99))
})

test_that("set_percentiles argument works in pareto_frontier()", {
  basic_expr <- call(
    "pareto_frontier",
    r5r_core,
    points[1:5],
    points[1:5],
    mode = c("TRANSIT", "WALK"),
    departure_datetime = departure_datetime,
    fare_structure = fare_structure,
    fare_cutoffs = c(0, 5, 10),
    time_window = 30,
    max_trip_duration = 60
  )

  one_percent_expr <- many_percent_expr <- basic_expr
  one_percent_expr$percentiles <- 50
  many_percent_expr$percentiles <- c(1, 50, 99)

  one_percent <- eval(one_percent_expr)
  expect_type(one_percent$percentile, "integer")
  expect_true(unique(one_percent$percentile) == 50)

  many_percent <- eval(many_percent_expr)
  expect_type(many_percent$percentile, "integer")
  expect_equal(unique(many_percent$percentile), c(1, 50, 99))

  # all 0 cost trips must be identical

  zero_cost <- many_percent[monetary_cost == 0]
  zero_cost <- data.table::dcast(
    zero_cost,
    from_id + to_id ~ percentile,
    value.var = "travel_time"
  )
  data.table::setnames(
    zero_cost,
    old = as.character(c(1, 50, 99)),
    new = paste0("travel_time_", c(1, 50, 99))
  )
  expect_identical(zero_cost$travel_time_1, zero_cost$travel_time_50)
  expect_identical(zero_cost$travel_time_50, zero_cost$travel_time_99)

  # each percentile-value defines their own frontiers

  is_pareto_frontier <- function(df) {
    travel_times_decrease <- all(diff(df$travel_time) < 0)
    monetary_costs_increase <- all(diff(df$monetary_cost) > 0)
    return(travel_times_decrease && monetary_costs_increase)
  }

  many_percent <- many_percent[
    ,
    .(data = list(.SD)),
    by = .(from_id, to_id, percentile)
  ]
  many_percent[
    ,
    is_pareto_frontier := vapply(data, is_pareto_frontier, logical(1))
  ]
  expect_true(all(many_percent$is_pareto_frontier))
})