tests/testthat/test-dynamic.R

In dynamicpv: Evaluates Present Values and Health Economic Models with Dynamic Pricing and Uptake

# Test the dynamic calculations

# Get data
democe <- get_dynfields(
  heemodel = oncpsm,
  payoffs = c("cost_daq_new", "cost_total", "qaly"),
  discount = "disc"
  )

# Get discount rate
discrate <- get_param_value(oncpsm, "disc")

# Obtain payoff vector of interest
payoffs <- democe |>
  dplyr::filter(int=="new") |>
  dplyr::mutate(cost_oth = cost_total_rup - cost_daq_new_rup)
Nt <- nrow(payoffs)

# 1. Simple calculation - one off uptake, no price escalation, no discounting
test_that("Simple calculation", {
  # Actual
  act_dval1 <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = rep(1, Nt),
    discrate = discrate
  )
  # Expected
  exp_dval1 <- sum(payoffs$cost_total - payoffs$cost_daq_new)
  # Test total and mean
  expect_equal(total(act_dval1), exp_dval1)
  expect_equal(mean(act_dval1), exp_dval1)
})

# 2. As (1) but with 5 x the uptake
test_that("5x the uptake of (1)", {
  # Actual
  act_dval2 <- dynpv(
    uptakes = c(5, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = rep(1, Nt),
    discrate = discrate
    )
  # Expected
  exp_dval2 <- 5 * sum(payoffs$cost_total - payoffs$cost_daq_new)
  # Test total and mean
  expect_equal(total(act_dval2), exp_dval2)
  expect_equal(mean(act_dval2), exp_dval2/5)
})

# 3. As (1) but with discounting at 1.5%
test_that("As (1) but 1.5% discounting", {
  # Actual
  act_dval3 <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = rep(1, Nt),
    discrate = 0.015
    )
  # Expect
  vt <- (1.015)^(1-(1:Nt))
  exp_dval3 <- sum(vt * (payoffs$cost_total_rup - payoffs$cost_daq_new_rup))
  # Test total and mean
  expect_equal(total(act_dval3), exp_dval3)
  expect_equal(mean(act_dval3), exp_dval3)
})

# 4. As (3) but with 1% increasing price index
test_that("As (1) but 1% price increases", {
  # Actual
  prices <- 1.01^((1:Nt)-1)
  act_dval4 <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = prices,
    discrate = 0.015
    )
  # Expected
  vt <- (1.015)^(1-(1:Nt))
  exp_dval4 <- sum(vt* prices * (payoffs$cost_total_rup - payoffs$cost_daq_new_rup))
  # Test total and mean
  expect_equal(total(act_dval4), exp_dval4)
  expect_equal(mean(act_dval4), exp_dval4)
})

# 5. As (1) but with flat incidence
test_that("As (1) but flat incidence", {
  # Actual
  act_dval5 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = rep(1, Nt),
    discrate = 0
    )
  # Expected
  exp_dval5 <- sum((Nt:1) * payoffs$cost_oth)
  # Test total and mean
  expect_equal(total(act_dval5), exp_dval5)
  expect_equal(mean(act_dval5), exp_dval5/Nt)
})

# 6. As (5) but with price increases
test_that("As (5) but with price increases", {
  # Actual
  prices <- 1.01^((1:Nt)-1)
  act_dval6 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    discrate = discrate
    )
  # Expected lower bound - exp_dval5
  exp_dval6 <- sum((Nt:1) * payoffs$cost_oth)
  # Test mean only
  expect_gt(mean(act_dval6), exp_dval6)
})


# 7. As (6) but with multiple time points
test_that("As (6) but with multiple time points (tzero)", {
  # Actual
  prices <- 1.01^((1:(2*Nt))-1)
  tzero <- (0:4)*52
  act_dval6 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = tzero,
    discrate = discrate
  )
  # Expected
  exp_dval6_0 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = 0,
    discrate = discrate
  )
  exp_dval6_1 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = 1*52,
    discrate = discrate
  )
  exp_dval6_2 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = 2*52,
    discrate = discrate
  )
  exp_dval6_3 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = 3*52,
    discrate = discrate
  )
  exp_dval6_4 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = 4*52,
    discrate = discrate
  )
  # Test total and mean
  expect_equal(
    total(act_dval6)$total,
    c(total(exp_dval6_0), total(exp_dval6_1), total(exp_dval6_2),
      total(exp_dval6_3), total(exp_dval6_4))
  )
  expect_equal(
    mean(act_dval6)$mean,
    c(mean(exp_dval6_0), mean(exp_dval6_1), mean(exp_dval6_2),
      mean(exp_dval6_3), mean(exp_dval6_4)))
})


# 8. Test addition
test_that("Addition of two dynamic pv's", {
  # Actual
  act_dval8a <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth * (1:Nt),
    prices = rep(1, Nt),
    discrate = 0
    )
  act_dval8b <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = rep(1, Nt),
    discrate = 0
    )
  act_add <- act_dval8a + act_dval8b
  # Expected
  exp_dval8a <- sum(payoffs$cost_oth * (1:Nt))
  exp_dval8b <- sum(payoffs$cost_oth)
  # Test total and mean
  expect_equal(total(act_dval8a), exp_dval8a)
  expect_equal(total(act_dval8b), exp_dval8b)
  expect_equal(total(act_add), exp_dval8a + exp_dval8b)
  expect_equal(uptake(act_dval8a) + uptake(act_dval8b), 2)
})

# 9. Test subtraction of two pv's
test_that("Subtraction of two pv's", {
  # Actual
  act_dval8a <- dynpv(
    uptakes = c(2, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth * (1:Nt),
    prices = rep(1, Nt),
    discrate = 0
    )
  act_dval8b <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = rep(1, Nt),
    discrate = 0
    )
  act_sub <- act_dval8a - act_dval8b
  # Expected
  exp_dval8a <- 2 * sum(payoffs$cost_oth * (1:Nt))
  exp_dval8b <- sum(payoffs$cost_oth)
  # Test total
  expect_equal(total(act_dval8a), exp_dval8a)
  expect_equal(total(act_dval8b), exp_dval8b)
  expect_equal(total(act_sub), exp_dval8a - exp_dval8b)
  expect_equal(uptake(act_dval8a) - uptake(act_dval8b), 2-1)
})

# 10. No error when running print
test_that("No error when applying print summary", {
  # Some sample dynpv values
  prices <- 1.01^((1:(2*Nt))-1)
  act_dval4 <- dynpv(
    uptakes = c(1, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth,
    prices = prices,
    discrate = 0.015
  )
  tzero <- (0:4)*52
  act_dval6 <- dynpv(
    uptakes = rep(1, Nt),
    payoffs = payoffs$cost_oth,
    prices = prices,
    tzero = tzero,
    discrate = discrate
  )
  act_dval8a <- dynpv(
    uptakes = c(2, rep(0, Nt-1)),
    payoffs = payoffs$cost_oth * (1:Nt),
    prices = rep(1, Nt),
    discrate = 0
  )
  # Check no error
  expect_no_error(print(summary(act_dval4)))
  expect_no_error(print(summary(act_dval8a)))
  expect_no_error(print(summary(act_dval4 + act_dval8a)))
  expect_no_error(print(summary(act_dval4 - act_dval8a)))
  expect_no_error(print(summary(act_dval6)))
})