tests/testthat/test_wane.R

In survextrap: Bayesian Flexible Parametric Survival Modelling and Extrapolation

alpha <- -0.35
coefs <- c(0.0012, 0.029, 0.1, 0.15, 0.23, 0.0074, 0.052, 0.1)
knots <- c(0.36, 0.62, 0.91, 1.2, 1.54, 2.02, 3)

test_that("wane functions",{
  pnw <- psurvmspline(q=c(10,14,18), alpha=alpha, coefs=coefs, knots=knots)
  pw <- psurvmspline_wane(q=10, alpha1=alpha, alpha0=-0.2, coefs1=coefs, coefs0=coefs,
                          knots=knots, wane_period=c(11, 15))
  hnw <- hsurvmspline(x=c(10,14,18), alpha=alpha, coefs=coefs, knots=knots)
  expect_equal(hnw[1],hnw[3])
  hw <- hsurvmspline_wane(x=c(10,14,18), alpha1=alpha, alpha0=-0.2, coefs1=coefs, coefs0=coefs,
                          knots=knots, wane_period=c(11, 15))
  dnw <- dsurvmspline(x=10, alpha=alpha, coefs=coefs, knots=knots)
  dw <- dsurvmspline_wane(x=10, alpha1=alpha, alpha0=-0.2, coefs1=coefs, coefs0=coefs,
                          knots=knots, wane_period=c(11, 15))
  expect_equal(pnw[1], pw[1])
  expect_equal(dnw[1], dw[1])
  expect_equal(hnw[1], hw[1])
  expect_lt(hnw[2], hw[2])
  expect_lt(hnw[3], hw[3])
})

test_that("wane functions: vectorisation over parameters",{
  h1 <- Hsurvmspline_wane(x=c(8, 10), alpha1=-1, alpha0=-2,
                          coefs1=coefs, coefs0=coefs, knots=knots, wane_period=c(9, 11))
  h2 <- Hsurvmspline_wane(x=c(8, 10), alpha1=-3, alpha0=-4,
                          coefs1=coefs, coefs0=coefs, knots=knots, wane_period=c(9, 11))
  h12 <- Hsurvmspline_wane(x=c(8, 10), alpha1=c(-1,-3), alpha0=c(-2,-4),
                           coefs1=coefs, coefs0=coefs, knots=knots, wane_period=c(9, 11))
  expect_equal(h12, c(h1[1], h2[2]))
})

test_that("wane functions: vectorisation errors",{
  expect_error(Hsurvmspline_wane(x=c(0, 8, 10, 12), alpha1=rep(alpha,2), alpha0=alpha*1.01,
                               coefs1=coefs, coefs0=coefs, knots=knots, wane_period=c(9, 11)),
             "lengths of `alpha0`")
})

mod <- survextrap(Surv(years, status) ~ rx, data=colons, fit_method="opt")

test_that("default newdata0",{
  nd <- data.frame(rx = c("Obs", "Lev+5FU"))
  nd0 <- data.frame(rx = c("Obs", "Obs"))
  rd <- rmst(mod, wane_period=c(2,3), t=7, niter=5, wane_nt=2)
  rn <- rmst(mod, newdata0=nd0, newdata=nd, wane_period=c(2,3), t=7, niter=5, wane_nt=2)
  expect_equal(rd$median[c(1,3)], rn$median, tol=1e-06)
})

test_that("rmst wane",{
  rd <- rmst(mod, t=2, niter=5)
  rd2 <- rmst(mod, t=2, wane_period=c(5,7), niter=5)
  expect_equal(rd$median, rd2$median)
  rd <- rmst(mod, t=5, niter=5)
  rd2 <- rmst(mod, t=5, wane_period=c(3,5), niter=5)
  expect_lt(rd2$median[2], rd$median[2])
})