tests/testthat/test-eval_cs.R

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

test_that("arg sets", {
  # empty set
  rs <- eval_cs(list(), output="foo")
  expect_contains(names(rs), c("pred","obs","wgts","times","tags")) # partial check only
  expect_length(rs$obs, 0)
  expect_length(rs$pred, 0)
  expect_length(rs$times, 0)

  # single set
  sc <- GUTS_RED_IT()
  cs <- caliset(sc, data.frame(t=0:2, o=3:5), weight=6:8, tag="foo")
  pred <- 1:3
  rs <- with_mocked_bindings(eval_cs(list(cs), output="bar"),
    simulate=function(x, ...) {
      data.frame(time=get_times(x), "bar"=pred)
    })
  expect_equal(rs$obs, cs@data[, 2])
  expect_equal(rs$pred, pred)
  expect_equal(rs$times, cs@data[, 1])
  expect_equal(rs$wgts, cs@weight)
  expect_equal(rs$tags, as.list(rep(cs@tag, nrow(cs@data))))

  # multiple sets
  cs2 <- caliset(sc, data.frame(t=1:3, o=4:6), weight=7:9, tag="bar")
  rs <- with_mocked_bindings(eval_cs(list(cs, cs2), output="bar"),
    simulate=function(x, ...) {
     data.frame(time=get_times(x), "bar"=pred)
    })
  expect_equal(rs$obs, c(cs@data[, 2], cs2@data[, 2]))
  expect_equal(rs$pred, c(pred, pred))
  expect_equal(rs$times, c(cs@data[, 1], cs2@data[, 1]))
  expect_equal(rs$wgts, c(cs@weight, cs2@weight))
  expect_equal(rs$tags, as.list(c(rep(cs@tag, nrow(cs@data)),
                                rep(cs2@tag, nrow(cs2@data)))))
})

test_that("arg output", {
  sc <- GUTS_RED_IT()
  cs <- caliset(sc, data.frame(t=0:2, o=3))
  rs <- with_mocked_bindings(eval_cs(list(cs), output="baz"),
    simulate=function(x, ...) {
     data.frame(time=get_times(x), bar=8, baz=9)
    })
  expect_equal(rs$pred, c(9, 9, 9))
})

test_that("arg method/ode_method", {
  sc <- GUTS_RED_IT()
  cs <- caliset(sc, data.frame(t=0:1, o=3))
  fsim <- function(x, method=0, ...) data.frame(time=get_times(x), foo=method)

  # no method requested
  rs <- with_mocked_bindings(eval_cs(list(cs), output="foo"), simulate=fsim)
  expect_equal(rs$pred, c(0, 0))
  # arg 'method' set
  rs <- with_mocked_bindings(eval_cs(list(cs), output="foo", method="bar"), simulate=fsim)
  expect_equal(rs$pred, c("bar", "bar"))
  # arg 'ode_method' set
  rs <- with_mocked_bindings(eval_cs(list(cs), output="foo", ode_method="bar"), simulate=fsim)
  expect_equal(rs$pred, c("bar", "bar"))
  # arg 'ode_method' overwrites arg 'method'
  rs <- with_mocked_bindings(eval_cs(list(cs), output="foo", ode_method="bar", method="baz"), simulate=fsim)
  expect_equal(rs$pred, c("bar", "bar"))
})

test_that("arg verbose", {
  sc <- GUTS_RED_IT()
  cs <- caliset(sc, data.frame(t=0:1, o=3))
  fsim <- function(x, method=0, ...) data.frame(time=get_times(x), foo=NA)

  # message
  expect_message(with_mocked_bindings(eval_cs(list(cs), output="foo", verbose=TRUE), simulate=fsim), "contains NA")
  # no message
  expect_no_message(with_mocked_bindings(eval_cs(list(cs), output="foo", verbose=FALSE), simulate=fsim))
})

test_that("arg .suppress", {
  sc <- GUTS_RED_IT()
  cs <- caliset(sc, data.frame(t=0:1, o=3))
  ferror <- function(x, ...) stop("foobar")

  # error: try-error object
  expect_warning(
      with_mocked_bindings(rs <- eval_cs(list(cs), output="foo", verbose=FALSE, .suppress=FALSE), simulate=ferror),
      "with caliset #1"
  )
  expect_true(rs$is_error)
  expect_false(rs$is_issue)
  expect_equal(rs$err_msg, "foobar")

  # issue: desolve aborted
  faborted <- function(x, ...) {
    df <- data.frame(time=0:1, foo=0)
    attr(df, "desolve_diagn") <- list(istate=-1)
    df
  }
  with_mocked_bindings(rs <- eval_cs(list(cs), output="foo", verbose=FALSE, .suppress=TRUE), simulate=faborted)
  expect_false(rs$is_error)
  expect_true(rs$is_issue)
  expect_equal(rs$err_msg, "simulation terminated early")
})