Nothing
data_path <- system.file("extdata/spo_gtfs.zip", package = "gtfstools")
gtfs <- read_gtfs(data_path)
trip_id <- "CPTM L07-0"
tester <- function(gtfs = get("gtfs", envir = parent.frame()),
trip_id = NULL,
file = "shapes",
unit = "km/h") {
get_trip_speed(gtfs, trip_id, file, unit)
}
test_that("raises errors due to incorrect input types/value", {
expect_error(tester(unclass(gtfs)))
expect_error(tester(trip_id = as.factor("CPTM L07-0")))
expect_error(tester(trip_id = NA))
expect_error(tester(file = c("shape", "stop_times")))
expect_error(tester(unit = "km/s"))
})
test_that("raises errors if gtfs doesn't have required files/fields", {
no_trips_gtfs <- copy_gtfs_without_file(gtfs, "trips")
no_shapes_gtfs <- copy_gtfs_without_file(gtfs, "shapes")
no_stops_gtfs <- copy_gtfs_without_file(gtfs, "stops")
no_stop_times_gtfs <- copy_gtfs_without_file(gtfs, "stop_times")
no_trp_tripid_gtfs <- copy_gtfs_without_field(gtfs, "trips", "trip_id")
no_trp_shapeid_gtfs <- copy_gtfs_without_field(gtfs, "trips", "shape_id")
no_shp_shapeid_gtfs <- copy_gtfs_without_field(gtfs, "shapes", "shape_id")
no_shp_shapeptlat_gtfs <- copy_gtfs_without_field(
gtfs, "shapes", "shape_pt_lat"
)
no_shp_shapeptlon_gtfs <- copy_gtfs_without_field(
gtfs, "shapes", "shape_pt_lon"
)
no_stt_tripid_gtfs <- copy_gtfs_without_field(gtfs, "stop_times", "trip_id")
no_stt_stopid_gtfs <- copy_gtfs_without_field(gtfs, "stop_times", "stop_id")
no_stt_arrtime_gtfs <- copy_gtfs_without_field(
gtfs, "stop_times", "arrival_time"
)
no_stt_deptime_gtfs <- copy_gtfs_without_field(
gtfs, "stop_times", "departure_time"
)
no_sto_stopid_gtfs <- copy_gtfs_without_field(gtfs, "stops", "stop_id")
no_sto_stoplat_gtfs <- copy_gtfs_without_field(gtfs, "stops", "stop_lat")
no_sto_stoplon_gtfs <- copy_gtfs_without_field(gtfs, "stops", "stop_lon")
# file = "shapes"
expect_error(tester(no_trips_gtfs, trip_id), class = "missing_required_file")
expect_error(tester(no_shapes_gtfs, trip_id), class = "missing_required_file")
expect_error(
tester(no_stop_times_gtfs, trip_id),
class = "missing_required_file"
)
expect_error(
tester(no_trp_tripid_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_trp_shapeid_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_shp_shapeid_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_shp_shapeptlat_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_shp_shapeptlon_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_stt_tripid_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_stt_arrtime_gtfs, trip_id),
class = "missing_required_field"
)
expect_error(
tester(no_stt_deptime_gtfs, trip_id),
class = "missing_required_field"
)
# file = "stop_times"
expect_error(
tester(no_stops_gtfs, trip_id, "stop_times"),
class = "missing_required_file"
)
expect_error(
tester(no_stop_times_gtfs, trip_id, "stop_times"),
class = "missing_required_file"
)
expect_error(
tester(no_trp_tripid_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_stt_tripid_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_stt_arrtime_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_stt_deptime_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_stt_stopid_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_sto_stopid_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_sto_stoplat_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_sto_stoplon_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_stt_arrtime_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
expect_error(
tester(no_stt_deptime_gtfs, trip_id, "stop_times"),
class = "missing_required_field"
)
})
test_that("raises warnings if a non_existent trip_id is given", {
expect_warning(tester(trip_id = c("CPTM L07-0", "ola")))
expect_warning(tester(trip_id = "ola"))
})
test_that("gets the speed of correct 'trip_id's", {
# if 'trip_id' = NULL, all trips have their geometries returned
all_trip_ids <- unique(gtfs$trips$trip_id)
all_trip_ids <- all_trip_ids[order(all_trip_ids)]
speeds_all_trip_ids <- tester()
trip_ids_from_speeds <- unique(speeds_all_trip_ids$trip_id)
trip_ids_from_speeds <- trip_ids_from_speeds[order(trip_ids_from_speeds)]
expect_identical(all_trip_ids, trip_ids_from_speeds)
# else, only the duration of (valid) trip_ids are calculated
selected_trip_ids <- c("CPTM L07-0", "ola")
suppressWarnings(
speeds_selected_trip_ids <- tester(trip_id = selected_trip_ids)
)
expect_equal(unique(speeds_selected_trip_ids$trip_id), "CPTM L07-0")
})
test_that("calculates the speed based on correct 'file'", {
shape_speed <- tester(trip_id = "CPTM L07-0")
stop_times_speed <- tester(trip_id = "CPTM L07-0", file = "stop_times")
both_speed <- tester(
gtfs,
"CPTM L07-0",
file = c("shapes", "stop_times")
)
expect_equal(unique(shape_speed$origin_file), "shapes")
expect_equal(unique(stop_times_speed$origin_file), "stop_times")
expect_identical(unique(both_speed$origin_file), c("shapes", "stop_times"))
})
test_that("outputs a 'data.table' with correct column types", {
speeds_dt <- tester(trip_id = "CPTM L07-0")
expect_s3_class(speeds_dt, "data.table")
expect_equal(class(speeds_dt$trip_id), "character")
expect_equal(class(speeds_dt$origin_file), "character")
expect_equal(class(speeds_dt$speed), "numeric")
# should work even when no given 'trip_id's given are present in the gtfs
expect_warning(speeds_dt <- tester(trip_id = "ola"))
expect_s3_class(speeds_dt, "data.table")
expect_equal(class(speeds_dt$trip_id), "character")
expect_equal(class(speeds_dt$origin_file), "character")
expect_equal(class(speeds_dt$speed), "numeric")
# and when trip_id = character(0)
speeds_dt <- tester(trip_id = character(0))
expect_s3_class(speeds_dt, "data.table")
expect_equal(class(speeds_dt$trip_id), "character")
expect_equal(class(speeds_dt$origin_file), "character")
expect_equal(class(speeds_dt$speed), "numeric")
})
test_that("outputs speeds in correct unit", {
# km/h
kmh_speeds_dt <- tester(trip_id = "CPTM L07-0", unit = "km/h")
trip_id_len <- sf::st_length(get_trip_geometry(gtfs, "CPTM L07-0", "shapes"))
trip_id_len <- as.numeric(units::set_units(trip_id_len, "km"))
trip_id_duration <- get_trip_duration(gtfs, "CPTM L07-0", unit = "h")
expect_equal(trip_id_len / trip_id_duration$duration, kmh_speeds_dt$speed)
# m/s
ms_speeds_dt <- tester(trip_id = "CPTM L07-0", unit = "m/s")
trip_id_len <- sf::st_length(get_trip_geometry(gtfs, "CPTM L07-0", "shapes"))
trip_id_len <- as.numeric(units::set_units(trip_id_len, "m"))
trip_id_duration <- get_trip_duration(gtfs, "CPTM L07-0", unit = "s")
expect_equal(trip_id_len / trip_id_duration$duration, ms_speeds_dt$speed)
# km/h = 3.6 * m/s
expect_equal(kmh_speeds_dt$speed, ms_speeds_dt$speed * 3.6)
})
test_that("doesn't change given gtfs", {
# (except for 'stop_times' and 'shapes' indices)
original_gtfs <- read_gtfs(data_path)
gtfs <- read_gtfs(data_path)
expect_identical(original_gtfs, gtfs)
speeds <- tester(trip_id = "CPTM L07-0", file = c("shapes", "stop_times"))
expect_false(identical(original_gtfs, gtfs))
data.table::setindex(gtfs$shapes, NULL)
data.table::setindex(gtfs$stop_times, NULL)
expect_identical(original_gtfs, gtfs)
})
# issue #35
test_that("warnings works properly", {
# should raise warning if trip_id is specified and doesn't exist (and should
# not calculate speed, instead of returning NA)
gtfs$stop_times <- gtfs$stop_times[trip_id != "CPTM L07-0"]
expect_warning(
speed <- tester(trip_id = "CPTM L07-0")
)
expect_true(nrow(speed) == 0)
# but if trip_id is not specified, it should not raise a warning
expect_silent(speed <- tester())
expect_true(!any("CPTM L07-0" %chin% speed$trip_id))
expect_true(all(gtfs$stop_times$trip_id %chin% speed$trip_id))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.