tests/testthat/test-transition.R

In IxPopDyMod: Framework for Tick Population and Infection Modeling

# new_transition --------------------------------------------------------------
test_that("produces expected output with valid input", {

  trans <- new_transition(
    from = "a",
    to = "b",
    transition_type = "probability",
    mortality_type = NULL,
    fun = new_transition_function(constant_fun),
    predictors = NULL,
    parameters = new_parameters(a = 1)
  )

  # Comparing functions is hard and was failing in R CMD check. So we do it
  # separately, ignoring the bytecode attr, and compare the rest with a snapshot.
  expect_identical(
    object = trans$fun,
    expected = structure(constant_fun, class = "transition_function"),
    ignore_attr = "bytecode"
  )
  expect_snapshot(trans[names(trans) != "fun"])
})

test_that("throws error with invalid from input", {
  expect_error(
    new_transition(
      from = "a",
      to = "",
      transition_type = "probability",
      mortality_type = NULL,
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    ),
    "All elements must have at least 1 characters"
  )

  expect_error(
    new_transition(
      from = NULL,
      to = "b",
      transition_type = "probability",
      mortality_type = NULL,
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    ),
    "Must be of type 'string'"
  )
})

test_that("throws error with invalid to input", {
  expect_error(
    new_transition(
      from = "a",
      to = "",
      transition_type = "probability",
      mortality_type = NULL,
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    ),
    "All elements must have at least 1 characters",
  )
})

# validate_transition() -------------------------------------------------------
test_that("probability transitions can only have per day mortality", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "throughout_transition",
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    )),
    "`probability` transitions only support `per_day` mortality"
  )
})

test_that("ensures that either mortality_type or to is NULL", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = NULL,
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    )),
    "exactly 1 of `to` or `mortality_type` must be non-NULL"
  )

  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = "b",
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    )),
    "exactly 1 of `to` or `mortality_type` must be non-NULL"
  )

  expect_error(validate_transition(new_transition(
    from = "a",
    to = NULL,
    transition_type = "probability",
    mortality_type = "per_day",
    fun = new_transition_function(constant_fun),
    predictors = NULL,
    parameters = new_parameters(a = 1)
  )), regexp = NA)

  expect_error(validate_transition(new_transition(
    from = "a",
    to = "b",
    transition_type = "probability",
    mortality_type = NULL,
    fun = new_transition_function(constant_fun),
    predictors = NULL,
    parameters = new_parameters(a = 1)
  )), regexp = NA)
})

test_that("catches extra parameters not needed in transition function", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(constant_fun),
      predictors = NULL,
      parameters = new_parameters(a = 1, b = 2)
    )),
    regexp = "has extra elements {'b'}",
    fixed = TRUE
  )
})

test_that("catches missing parameters needed in transition function", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(function(a, b) a),
      predictors = NULL,
      parameters = new_parameters(b = 1)
    )),
    regexp = "is missing elements {'a'}.",
    fixed = TRUE
  )
})

test_that("allows transition with zero parameters", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(function(x, y) NULL),
      predictors = list(x = predictor_spec("temp"), y = predictor_spec("host_density")),
      parameters = new_parameters()
    )),
    regexp = NA
  )
})

test_that("catches extra predictors not needed in transition function", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(constant_fun),
      predictors = list(z = predictor_spec("extra")),
      parameters = new_parameters(a = 1)
    )),
    regexp = (
      "has extra elements {'z'}"
    ),
    fixed = TRUE
  )
})

test_that("catches missing predictors needed in transition function", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(function(a, y) a),
      predictors = NULL,
      parameters = new_parameters(a = 1)
    )),
    regexp = "is missing elements {'y'}.",
    fixed = TRUE
  )
})

test_that("catches duplicate names between parameters and predictors", {
  expect_error(
    validate_transition(new_transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = new_transition_function(constant_fun),
      predictors = list(a = predictor_spec("duplicate name")),
      parameters = new_parameters(a = 1)
    )),
    regexp = "Must be disjunct from {'a'}, but has elements {'a'}.",
    fixed = TRUE
  )
})

test_that("catches probability-type transitions with predictors with `first_day_only` as `FALSE`", {
  expect_error(
    transition(
      from = "a",
      to = NULL,
      transition_type = "probability",
      mortality_type = "per_day",
      fun = function(a, b, c) 1,
      predictors = list(
        a = predictor_spec("problem1", first_day_only = FALSE),
        b = predictor_spec("problem2", first_day_only = FALSE),
        c = predictor_spec("not_a_problem", first_day_only = TRUE)
      )
    ),
    regexp = "cannot have any predictors where the `first_day_only` attribute is `FALSE`"
  )
})

# transition() ----------------------------------------------------------------
test_that("works with defaults", {

  # Need to set the environment so it doesn't change in snapshots
  f <- function() NULL
  environment(f) <- emptyenv()

  expect_snapshot(transition(
    from = "a",
    to = "b",
    fun = f,
    transition_type = "probability"
  ))
})

test_that("can handle vector parameters input", {
  result <- transition(
    from = "a",
    to = "b",
    fun = new_transition_function(function(a) NULL),
    transition_type = "probability",
    parameters = c(a = 1)
  )

  expect_s3_class(result$parameters, "parameters")
})

test_that("can coerce input fun to transition_function", {
  result <- transition(
    from = "a",
    to = "b",
    fun = function(a) NULL,
    transition_type = "probability",
    parameters = new_parameters(a = 1)
  )

  expect_s3_class(result$fun, "transition_function")
})

# transition_is_mortality -----------------------------------------------------
test_that("correctly identifies mortality", {
  transition <- transition(
    from = "a",
    to = NULL,
    transition_type = "probability",
    mortality_type = "per_day",
    fun = function() NULL,
  )
  expect_true(transition_is_mortality(transition))
})

test_that("correctly identifies no mortality", {
  transition <- transition(
    from = "a",
    to = "b",
    transition_type = "probability",
    mortality_type = NULL,
    fun = function() NULL,
  )
  expect_false(transition_is_mortality(transition))
})