tests/testthat/test-yr.R

In era: Year-Based Time Scales

test_that("yr() returns a zero-length yr", {
  expect_s3_class(yr(), "era_yr")
  expect_length(yr(), 0)
})

test_that("yr() constructs an era_yr with valid input", {
  expect_s3_class(yr(1:10, "BP"), "era_yr")
  expect_s3_class(yr(1:10/2, "ka"), "era_yr")
  expect_s3_class(yr(1:10, era("BP")), "era_yr")
})

test_that("yr validation functions work", {
  good_yr <- yr(1, "BP")
  bad_yr <- new_yr("a", NA)
  not_yr <- 1
  expect_true(is_yr(good_yr))
  expect_true(is_valid_yr(good_yr))
  expect_silent(validate_yr(good_yr))
  expect_true(is_yr(bad_yr))
  expect_false(is_valid_yr(bad_yr))
  expect_error(validate_yr(bad_yr))
  expect_false(is_yr(not_yr))
  expect_false(is_valid_yr(not_yr))
  expect_error(validate_yr(not_yr))
})

test_that("validate_yr() finds specific problems", {
  not_yr <- 1
  bad_yr_data <- new_yr(c("A", "B", "C"), era("BP"))
  bad_yr_null_era <- new_yr(1, NULL)
  bad_yr_na_era <- new_yr(1, NA)
  bad_yr_multiple_era <- new_yr(1, era(c("BP", "BC")))
  bad_yr_invalid_era <- new_yr(1, new_era("x", "x", "x", "x", "x", "x"))

  expect_error(validate_yr(not_yr), class = "era_invalid_yr",
               regexp = "class era_yr")
  expect_error(validate_yr(bad_yr_data), class = "era_invalid_yr",
               regexp = "data")
  expect_error(validate_yr(bad_yr_null_era), class = "era_invalid_yr",
               regexp = "set")
  expect_error(validate_yr(bad_yr_na_era), class = "era_invalid_yr",
               regexp = "not NA")
  expect_error(validate_yr(bad_yr_multiple_era), class = "era_invalid_yr",
               regexp = "one era")
  expect_error(validate_yr(bad_yr_invalid_era), class = "era_invalid_yr",
               regexp = "valid era")
})

test_that("era_yr coercion is correct and symmetrical", {
  # era_yr <-> era_yr
  expect_s3_class(vec_c(yr(1, "BP"), yr(2, "BP")), "era_yr")
  expect_error(vec_c(yr(1, "BP"), yr(2, "BC")),
               class = "vctrs_error_incompatible_type")

  # integer <-> era_yr
  expect_s3_class(vec_c(1L, yr(2L, "BP")), "era_yr")
  expect_s3_class(vec_c(yr(1L, "BP"), 2L), "era_yr")

  # double <-> era_yr
  expect_s3_class(vec_c(1.0, yr(2.0, "BP")), "era_yr")
  expect_s3_class(vec_c(yr(1.0, "BP"), 2.0), "era_yr")
})

test_that("era_yr cast methods return correct class", {
  # era_yr <-> era_yr
  expect_s3_class(vec_cast(yr(1, "BP"), yr(2, "BP")), "era_yr")
  expect_error(vec_cast(yr(1, "BP"), yr(2, "BC")),
               class = "vctrs_error_incompatible_type")

  # integer <-> era_yr
  expect_type(vec_cast(new_yr(), integer()), "integer")
  expect_s3_class(vec_cast(integer(), new_yr()), "era_yr")

  # double <-> era_yr
  expect_type(vec_cast(new_yr(), double()), "double")
  expect_s3_class(vec_cast(double(), new_yr()), "era_yr")

  # character <-> era_yr
  expect_type(vec_cast(new_yr(), character()), "character")
  expect_error(vec_cast(character(), new_yr()),
               class = "vctrs_error_incompatible_type")
})

test_that("casting era_yr to character returns expected output", {
  expect_equal(vec_cast(yr(1:3, "BP"), character()), c("1 BP", "2 BP", "3 BP"))
})

test_that("format.era_yr returns expected output", {
  expect_snapshot_output(yr(1, "BP"))
})

test_that("tibble formatter pillar_shaft.era_yr returns expected output", {
  expect_snapshot_output(tibble::tibble(x = yr(1:10, "BP")))
})

test_that("yr arithmetic respects era equality", {
  expect_condition(yr(1, "BP") + yr(1, "BP"), NA)
  expect_warning(yr(1, "BP") + yr(1, "cal BP"), class = "era_lossy_coercion")
  expect_warning(yr(1, "BC") + yr(1, "BCE"), class = "era_lossy_coercion")
  expect_error(yr(1, "BP") + yr(1, "BC"), class = "vctrs_error_incompatible")
})

test_that("yr arithmetic preserves era where appropriate", {
  # switch statements in vec_arith.* "fall through" to lowest operator, so only
  # need to test that
  expect_s3_class(yr(1, "BP") - yr(1, "BP"), "era_yr")
  expect_s3_class(yr(1, "BP") - 1, "era_yr")
  expect_s3_class(1 - yr(1, "BP"), "era_yr")
})

test_that("yr arithmetic strips era where appropriate", {
  # switch statements in vec_arith.* "fall through" to lowest operator, so only
  # need to test that
  expect_s3_class(yr(10, "BP") %/% yr(2, "BP"), NA)
  expect_s3_class(yr(10, "BP") %/% 2, NA)
  expect_s3_class(2 %/% yr(10, "BP"), NA)
})

test_that("unary arithmetic operators work with yrs", {
  expect_equal(-yr(1, "BP"), yr(-1, "BP"))
  expect_equal(+yr(1, "BP"), yr(1, "BP"))
})

test_that("yr get and set functions work", {
  x <- yr(1, "BP")
  expect_equal(yr_era(x), era("BP"))
  x <- yr_set_era(x, era("ka"))
  expect_equal(yr_era(x), era("ka"))
  yr_era(x) <- era("BCE")
  expect_equal(yr_era(x), era("BCE"))
  y <- yr_set_era(1, era("mya"))
  expect_equal(yr_era(y), era("mya"))
})