tests/testthat/test-sequence.R

In cvasi: Calibration, Validation, and Simulation of TKTD Models

test_that("sequence creation", {
  sc <- new("EffectScenario") %>% set_times(0:10)

  # single element
  expect_warning(sequence(list(sc)))
  # multiple elements
  expect_error(sequence(list(sc, sc)), "time overlap")
  sc2 <- sc %>% set_times(10:20)
  expect_equal(sequence(list(sc, sc2))@scenarios, list(sc, sc2))
})

test_that("split_sequence", {
  # scenarios overlap
  sc <- new("EffectScenario") %>% set_times(0:10)

  # single scenario, no changes
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(sq[[1]]@times, 0:10)

  # two scenarios, both scenarios include the break
  sq <- sequence(list(sc, sc), breaks=5)
  expect_equal(sq[[1]]@times, 0:5)
  expect_equal(sq[[2]]@times, 5:10)
  expect_equal(sq@inc_start, c(TRUE, FALSE))
  expect_equal(sq@inc_end, c(TRUE, TRUE))

  # break before the first scenario
  sq <- sequence(list(sc, sc), breaks=-1)
  expect_equal(sq[[1]]@times, integer(0))
  expect_equal(sq[[2]]@times, 0:10)
  expect_equal(sq@inc_start, c(FALSE, TRUE))
  expect_equal(sq@inc_end, c(FALSE, TRUE))

  # break after the second scenario
  sq <- sequence(list(sc, sc), breaks=11)
  expect_equal(sq[[1]]@times, 0:10)
  expect_equal(sq[[2]]@times, integer(0))
  expect_equal(sq@inc_start, c(TRUE, FALSE))
  expect_equal(sq@inc_end, c(TRUE, FALSE))


  suppressMessages(l <- sequence(list(sc, sc), breaks=1)@scenarios)
  expect_equal(l[[1]]@times, c(0, 1))
  expect_equal(l[[2]]@times, 1:10)

  suppressMessages(l <- sequence(list(sc, sc), breaks=9)@scenarios)
  expect_equal(l[[1]]@times, 0:9)
  expect_equal(l[[2]]@times, 9:10)

  suppressMessages(l <- sequence(list(sc, sc), breaks=0.5)@scenarios)
  expect_equal(l[[1]]@times, c(0, 0.5))
  expect_equal(l[[2]]@times, c(0.5, 1:10))

  suppressMessages(l <- sequence(list(sc, sc), breaks=9.5)@scenarios)
  expect_equal(l[[1]]@times, c(0:9, 9.5))
  expect_equal(l[[2]]@times, c(9.5, 10))

  # scenarios have a gap
  sc1 <- new("EffectScenario") %>% set_times(0:4)
  sc2 <- new("EffectScenario") %>% set_times(6:10)

  suppressMessages(l <- sequence(list(sc1, sc2), breaks=3)@scenarios)
  expect_equal(l[[1]]@times, 0:3)
  expect_equal(l[[2]]@times, c(3, 6:10))

  suppressMessages(l <- sequence(list(sc1, sc2), breaks=4)@scenarios)
  expect_equal(l[[1]]@times, 0:4)
  expect_equal(l[[2]]@times, c(4, 6:10))

  suppressMessages(l <- sequence(list(sc1, sc2), breaks=5)@scenarios)
  expect_equal(l[[1]]@times, 0:5)
  expect_equal(l[[2]]@times, 5:10)

  suppressMessages(l <- sequence(list(sc1, sc2), breaks=6)@scenarios)
  expect_equal(l[[1]]@times, c(0:4, 6))
  expect_equal(l[[2]]@times, 6:10)

  suppressMessages(l <- sequence(list(sc1, sc2), breaks=6.5)@scenarios)
  expect_equal(l[[1]]@times, c(0:4, 6.5))
  expect_equal(l[[2]]@times, c(6.5, 7:10))
})

test_that("set new times", {
  sc1 <- new("EffectScenario") %>% set_times(0:3)
  sc2 <- new("EffectScenario") %>% set_times(3:6)

  # no breaks
  suppressWarnings(sq <- sequence(list(sc1)) %>% set_times(1:5))
  expect_equal(sq[[1]]@times, 1:5)

  # some breaks
  sq <- sequence(list(sc1, sc2)) %>% set_times(1:5)
  expect_equal(sq[[1]]@times, 1:3)
  expect_equal(sq[[2]]@times, 3:5)

  # no output for 1st scenario in sequence
  sq <- sequence(list(sc1, sc2)) %>% set_times(5:7)
  expect_equal(sq[[1]]@times, numeric(0))
  expect_equal(sq[[2]]@times, 5:7)

  # no output for 2nd scenario in sequence
  sq <- sequence(list(sc1, sc2)) %>% set_times(1:3)
  expect_equal(sq[[1]]@times, 1:3)
  expect_equal(sq[[2]]@times, numeric(0))
})

test_that("invalid arguments", {
  sc <- new("EffectScenario") %>% set_times(0:10)

  expect_error(sequence())
  expect_error(sequence("foo"))
  expect_error(sequence(list()))
  expect_warning(sequence(list(sc)))
  expect_error(sequence(list(sc, "foo")))
  expect_error(sequence(list(sc, sc), breaks="foo"))
  expect_error(sequence(list(sc, sc), breaks=c(1, 2)))
})

test_that("breaks_from_sequence", {
  sc1 <- new("EffectScenario") %>% set_times(0:5)

  # no breaks
  suppressWarnings(sq <- sequence(list(sc1)))
  expect_equal(breaks_from_sequence(sq), numeric(0))
  # one break
  suppressMessages(sq <- sequence(list(sc1, sc1), breaks=3))
  expect_equal(breaks_from_sequence(sq), 3)
  # multiple breaks
  suppressMessages(sq <- sequence(list(sc1, sc1, sc1), breaks=c(2,3.1)))
  expect_equal(breaks_from_sequence(sq), c(2, 3.1))
})

test_that("included outputs", {
  # include breaks if scenarios were split by user
  sc1 <- minnow_it %>% set_times(0:3)
  sc2 <- minnow_it %>% set_times(3:6)
  sq <- sequence(list(sc1, sc2))
  expect_equal(sq@inc_start, c(TRUE, FALSE))
  expect_equal(sq@inc_end, c(TRUE, TRUE))

  # remove breaks from output if it was automatically split
  sc1 <- minnow_it %>% set_times(0:2)
  sc2 <- minnow_it %>% set_times(3:6)
  sq <- sequence(list(sc1, sc2), breaks=3)
  expect_equal(sq@inc_start, c(TRUE, FALSE))
  expect_equal(sq@inc_end, c(FALSE, TRUE))

  # multiple breaks
  sc <- minnow_it %>% set_times(0:6)
  sq <- sequence(list(sc, sc, sc), breaks=c(2.1, 4))
  expect_equal(sq@inc_start, c(TRUE, FALSE, FALSE))
  expect_equal(sq@inc_end, c(FALSE, TRUE, TRUE))
})

test_that("sequence_check", {
  sc <- new("EffectScenario")

  # gap in output times
  sc1 <- sc %>% set_times(1:2)
  sc2 <- sc %>% set_times(4:5)
  expect_error(sequence(list(sc1, sc2)), "time gap")
  # output time overlap
  sc1 <- sc %>% set_times(1:2)
  sc2 <- sc %>% set_times(1:3)
  expect_error(sequence(list(sc1, sc2)), "time overlap")
})

test_that("array access", {
  sc1 <- new("EffectScenario") %>% set_times(0:3)
  sc2 <- new("EffectScenario") %>% set_times(3:6)
  sc3 <- new("EffectScenario") %>% set_times(3:9)
  sq <- sequence(list(sc1, sc2))

  # multiple elements
  expect_equal(sq[1], list(sc1))
  expect_equal(sq[2], list(sc2))
  expect_equal(sq[c(1, 2)], list(sc1, sc2))

  # single elements
  expect_equal(sq[[1]], sc1)
  expect_equal(sq[[2]], sc2)

  # assignments
  sq[[2]] <- sc3
  expect_equal(sq[[2]], sc3)

  # invalid arguments
  expect_error(sq[0], "out of bounds")
  expect_error(sq[10], "out of bounds")
  expect_error(sq[c(0, 42)], "out of bounds")

  expect_error(sq[[0]], "out of bounds")
  expect_error(sq[[10]], "out of bounds")
  expect_error(sq[[c(1, 2)]], "length one")

  expect_error(sq[[c(1, 2)]] <- sc3, "length one")
  expect_error(sq[[0]] <- sc3, "out of bounds")
  expect_error(sq[[10]] <- sc3, "out of bounds")
})

test_that("mocking scenarios", {
  sq <- new("ScenarioSequence")
  sc <- new("EffectScenario", tag="foo", exposure=no_exposure()) %>% set_times(0:5)

  # slot not emulated yet -> fail
  expect_error(sq@tag)

  # mock from supplied scenario
  mock <- mock_as_scenario(sq, sc)
  expect_equal(mock@tag, sc@tag)

  # writing should fail
  expect_error(mock@tag <- "bar")
  # some slot should never be mocked
  expect_equal(mock@exposure, NA)

  # mock from first scenario in sequence
  sc1 <- sc %>% set_tag("baz")
  sq <- sequence(list(sc1, sc), breaks=3)
  mock <- mock_as_scenario(sq)
  expect_equal(mock@tag, sc1@tag)
  expect_equal(mock@times, sc@times)
})

test_that("mocked slots", {
  # newly created
  sc1 <- new("EffectScenario", tag="foo", times=0:5)
  sc2 <- sc1 %>% set_tag("bar")
  sq <- sequence(list(sc1, sc2), breaks=3)
  expect_equal(sq@tag, sc1@tag)

  # first scenario updated
  sq[[1]] <- sq[[1]] %>% set_tag("baz")
  expect_equal(sq[[1]]@tag, "baz")
  expect_equal(sq@tag, "baz")
})

test_that("with simulate()", {
  tol <- 1e-5

  # guts red it
  sc <- minnow_it
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(simulate(sq), simulate(sc), tolerance=tol)

  # lemna
  sc <- metsulfuron
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(simulate(sq), simulate(sc), tolerance=tol)

  # multiple elements in sequence
  suppressWarnings(sq <- sequence(list(sc, sc), breaks=3.1))
  expect_equal(simulate(sq), simulate(sc), ignore_attr=TRUE, tolerance=tol)
})

test_that("with fx()", {
  tol <- 1e-5

  # guts red it
  sc <- minnow_it
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(fx(sq), fx(sc), tolerance=tol)

  # lemna
  sc <- metsulfuron
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(fx(sq), fx(sc), tolerance=tol)
})

test_that("with effect()", {
  tol <- 1e-5

  # no moving windows
  sc <- minnow_it
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(effect(sq, ep_only=TRUE), effect(sc, ep_only=TRUE), ignore_attr=TRUE, tolerance=tol)

  # with moving windows
  sc <- minnow_it %>% set_window(length=2, interval=2)
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(effect(sq, ep_only=TRUE, max_only=FALSE),
               effect(sc, ep_only=TRUE, max_only=FALSE),
               ignore_attr=TRUE, tolerance=tol)

  sc <- minnow_it %>%
    set_exposure(data.frame(t=0:4, c=c(0, 0, 0, 1, 1))) %>%
    set_window(length=2, interval=2)
  sq <- sequence(list(sc, sc), breaks=2)
  expect_equal(effect(sq, ep_only=TRUE, max_only=FALSE),
               effect(sc, ep_only=TRUE, max_only=FALSE),
               ignore_attr=TRUE, tolerance=tol)
})

test_that("with epx()", {
  tol <- 1e-5

  # no moving windows
  sc <- minnow_it
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(epx(sc, ep_only=TRUE),
               epx(sq, ep_only=TRUE),
               tolerance=tol, ignore_attr=TRUE)

  # with moving windows
  sc <- sc %>%
    set_exposure(data.frame(t=0:4, c=c(0, 0, 0, 1, 1))) %>%
    set_window(length=2, interval=1)
  suppressWarnings(sq <- sequence(list(sc)))
  expect_equal(epx(sc, ep_only=TRUE),
               epx(sq, ep_only=TRUE),
               tolerance=tol, ignore_attr=TRUE)
})