tests/testthat/test_metamod.R

In dampack: Decision-Analytic Modeling Package

context("metamodel")
library(dampack)

# test the class
test_that("metamodel has all methods we'd expect", {
  current_methods <- as.vector(methods(class = "metamodel"))
  expected_methods <- c("predict.metamodel", "print.metamodel", "summary.metamodel")
  expect_setequal(current_methods, expected_methods)
})

# class creation

## setup
data("example_psa")
psa_big <- make_psa_obj(example_psa$cost, example_psa$effectiveness,
                        example_psa$parameters, example_psa$strategies)

test_that("metamodel object has correct classes", {
  mm <- metamodel(psa = psa_big, param = "pFailChemo", outcome = "cost")
  expect_is(mm, "metamodel")
})

# methods

test_that("metamodel with one outcome", {
  # metamodel
  ## linear
  mm_lin <- metamodel(psa = psa_big, params = "pFailChemo", outcome = "cost", strategies = "Chemo")
  expect_is(mm_lin, "metamodel")

  # predictions
  pred_lin <- predict(mm_lin)
  expect_equal(colnames(pred_lin),
               c("parameter", "strategy", "param_val", "outcome_val"))

  ## poly
  mm_poly <- metamodel(psa = psa_big, params = "pFailChemo", outcome = "cost", strategies = "Chemo",
                  type = "poly")
  expect_is(mm_poly, "metamodel")

  # predictions
  pred_poly <- predict(mm_poly)
  expect_equal(colnames(pred_poly),
               c("parameter", "strategy", "param_val", "outcome_val"))

  ## GAM
  mm_gam <- metamodel(psa = psa_big, params = "pFailChemo", outcome = "cost", strategies = "Chemo",
                  type = "gam")
  expect_is(mm_gam, "metamodel")

  # predictions
  pred_gam <- predict(mm_gam)
  expect_equal(colnames(pred_gam),
               c("parameter", "strategy", "param_val", "outcome_val"))
})

test_that("prediction with several outcomes", {
  # metamodel
  mm <- metamodel(psa = psa_big, outcome = "eff")
  expect_is(mm, "metamodel")

  # number of linear models
  expect_equal(length(mm$mods), 8)

  # number of strategies for each
  nstrats <- sapply(mm$mods, length)
  expect_setequal(nstrats, 3)

  # predictions - same colnames
  pred <- predict(mm)
  expect_equal(colnames(pred),
               c("parameter", "strategy", "param_val", "outcome_val"))
})

test_that("type and content checking with predict", {
  # metamodel
  mm <- metamodel(psa = psa_big, outcome = "eff")

  # good example 1:  a list with some parameters
  preds1 <- predict(mm,
                    ranges = list("pFailChemo" = c(0.3, 0.6),
                                  "pFailRadio" = c(0.4, 0.5)),
                    nsamp = 10)
  expect_equal(nrow(preds1), 60)

  # good example 2: a list with some NULL parameters
  preds2 <- predict(mm,
                    ranges = list("pFailChemo" = NULL,
                                  "pFailRadio" = NULL),
                    nsamp = 10)
  expect_equal(nrow(preds2), 60)

  # good example 3: a list with a custom range and a NULL
  preds3 <- predict(mm,
                    ranges = list("pFailChemo" = c(0.3, 0.6),
                                  "pFailRadio" = NULL),
                    nsamp = 10)
  expect_equal(nrow(preds3), 60)

  # bad example 1: someone passes vector
  expect_error(predict(mm, ranges = c("pFailChemo" = c(0.3, 0.6),
                                      "pFailRadio" = c(0.4, 0.5)),
                       nsamp = 10), regexp = "list")

  # bad example 2: pass list but with length 1 or 3
  expect_error(predict(mm, ranges = list("pFailChemo" = c(0), "pFailRadio" = c(0.3, 0.4)),
                       nsamp = 10), regexp = "length 2")

})

test_that("out of range warning", {
  # metamodel
  mm <- metamodel(psa = psa_big, outcome = "eff")

  # out of range
  expect_warning(predict(mm, ranges = list("pFailChemo" = c(-1, 1))),
                 regexp = "caution")

  # not out of range
  expect_silent(predict(mm, ranges = list("pFailChemo" = c(0.4, 0.3))))
})

test_that("two-way metamodel", {
  # metamodel
  mm <- metamodel(analysis = "twoway", params = c("pFailChemo", "pFailRadio"),
                psa = psa_big, outcome = "eff")
  expect_is(mm, "metamodel")
})