tests/testthat/test-Reaction.R

In rdecision: Decision Analytic Modelling in Health Economics

test_that("new object arguments are checked", {
  c1 <- ChanceNode$new("c1")
  t1 <- LeafNode$new("t1")
  p <- 0.5
  expect_silent(Reaction$new(c1, t1))
  r <- Reaction$new(c1, t1)
  expect_identical(r$p(), 0.0)
  expect_error(Reaction$new(c1, t1, p, label = 42L), class = "non-string_label")
  expect_error(Reaction$new(t1, c1, p), class = "invalid_source")
  expect_silent(Reaction$new(c1, t1, p))
  expect_error(Reaction$new(c1, t1, "0.5"), class = "invalid_probability")
  expect_error(Reaction$new(c1, t1, p, cost = "200"), class = "invalid_cost")
  expect_error(
    Reaction$new(c1, t1, p, benefit = "200"), class = "invalid_benefit"
  )
  expect_silent(Reaction$new(c1, t1, p, label = ""))
  expect_silent(Reaction$new(c1, t1, p, label = "mychance"))
})

test_that("class parameters are updated dynamically", {
  # create edge and check it
  c1 <- ChanceNode$new("d1")
  t1 <- LeafNode$new("t1")
  e1 <- Reaction$new(source = c1, target = t1, p = 0.5, label = "e")
  expect_identical(e1$cost(), 0.0)
  expect_identical(e1$benefit(), 0.0)
  expect_identical(e1$p(), 0.5)
  # attempt to set an invalid probability
  expect_error(e1$set_probability("0.42"), class = "invalid_probability")
  expect_error(e1$set_probability(), class = "invalid_probability")
  # check that probability can be set to NA
  e1$set_probability(p = NA_real_)
  expect_true(is.na(e1$p()))
  # set probability and check it
  e1$set_probability(0.42)
  expect_identical(e1$p(), 0.42)
  # attempt to set an invalid cost
  expect_error(e1$set_cost("42"), class = "invalid_cost")
  expect_error(e1$set_cost(NA_real_), class = "invalid_cost")
  # set cost to default, and check it
  e1$set_cost()
  expect_identical(e1$cost(), 0.0)
  # set cost and check it
  e1$set_cost(42.0)
  expect_identical(e1$cost(), 42.0)
  # attempt to set an invalid benefit
  expect_error(e1$set_benefit("42"), class = "invalid_benefit")
  expect_error(e1$set_benefit(NA_real_), class = "invalid_benefit")
  # set benefit to default, and check it
  e1$set_benefit()
  expect_identical(e1$benefit(), 0.0)
  # set cost and check it
  e1$set_benefit(42.0)
  expect_identical(e1$benefit(), 42.0)
})

test_that("argument name matching supports old names", {
  ns <- ChanceNode$new("c")
  nt <- LeafNode$new("l")
  expect_silent(Reaction$new(source = ns, target = nt, p = 0.5, label = "x"))
  expect_silent(
    Reaction$new(source = ns, target_node = nt, p = 0.5, label = "x")
  )
  expect_silent(
    Reaction$new(source_node = ns, target = nt, p = 0.5, label = "x")
  )
})

test_that("modvars are identified", {
  n1 <- ChanceNode$new("c")
  n2 <- LeafNode$new("n2")
  fortytwo <- ConstModVar$new("fortytwo", "GBP", 42.0)
  free <- ConstModVar$new("free", "GBP", 0.0)
  evens <- ConstModVar$new("evens", "P", 0.5)
  # one modvar
  e <- Reaction$new(
    n1, n2, p = 0.5, cost = 42.0, benefit = fortytwo, label = "label"
  )
  mv <- e$modvars()
  expect_length(mv, 1L)
  # two modvars
  e <- Reaction$new(
    n1, n2, p = 0.5, cost = free, benefit = fortytwo, label = "label"
  )
  mv <- e$modvars()
  expect_length(mv, 2L)
  d <- vapply(mv, FUN.VALUE = "x", FUN = function(v) {
    return(v$description())
  })
  expect_setequal(d, c("fortytwo", "free"))
  # three modvars
  e <- Reaction$new(
    n1, n2, p = evens, cost = free, benefit = fortytwo, label = "label"
  )
  mv <- e$modvars()
  expect_length(mv, 3L)
  d <- vapply(mv, FUN.VALUE = "x", FUN = function(v) {
    return(v$description())
  })
  expect_setequal(d, c("evens", "fortytwo", "free"))
  expect_identical(e$benefit(), 42.0)
  # add a modvar dynamically
  e <- Reaction$new(
    n1, n2, p = 0.5, cost = 42.0, benefit = fortytwo, label = "label"
  )
  mv <- e$modvars()
  expect_length(mv, 1L)
  e$set_cost(c = free)
  mv <- e$modvars()
  expect_length(mv, 2L)
})