tests/testthat/test-man.R

In VAJointSurv: Variational Approximation for Joint Survival and Marker Models

test_that("manual pages gives the same results as previously for joint_ms type functions", {
  # load in the data
  library(survival)
  data(pbc, package = "survival")

  # re-scale by year
  pbcseq <- transform(pbcseq, day_use = day / 365.25)
  pbc <- transform(pbc, time_use = time / 365.25)

  # create the marker terms
  m1 <- marker_term(
    log(bili) ~ 1, id = id, data = pbcseq,
    time_fixef = bs_term(day_use, df = 5L),
    time_rng = poly_term(day_use, degree = 1L, raw = TRUE, intercept = TRUE))
  m2 <- marker_term(
    albumin ~ 1, id = id, data = pbcseq,
    time_fixef = bs_term(day_use, df = 5L),
    time_rng = poly_term(day_use, degree = 1L, raw = TRUE, intercept = TRUE))

  # base knots on observed event times
  bs_term_knots <-
    with(pbc, quantile(time_use[status == 2], probs = seq(0, 1, by = .2)))

  boundary <- c(bs_term_knots[ c(1, length(bs_term_knots))])
  interior <- c(bs_term_knots[-c(1, length(bs_term_knots))])

  # create the survival term
  s_term <- surv_term(
    Surv(time_use, status == 2) ~ 1, id = id, data = pbc,
    time_fixef = bs_term(time_use, Boundary.knots = boundary, knots = interior))

  # create the C++ object to do the fitting
  model_ptr <- joint_ms_ptr(
    markers = list(m1, m2), survival_terms = s_term,
    max_threads = 2L, ders = list(0L, c(0L, -1L)))

  # find the starting values
  start_vals <- joint_ms_start_val(model_ptr)
  start_vals_to_test <- head(start_vals, 500)

  attributes(start_vals_to_test) <- attributes(start_vals)

  expect_snapshot_value(
    start_vals_to_test, style = "serialize",
    tolerance = 1e-3)

  expect_equal(attr(start_vals,"value"),
               joint_ms_lb(model_ptr,par = start_vals))

  VA_pars <- joint_ms_va_par(object = model_ptr,par = start_vals)

  expect_equal(length(VA_pars),length(unique(pbc$id)))

  expect_snapshot_value(VA_pars[1:10],
                        style = "serialize",
                        tolerance = 1e-3)

  vcov_vary <- diag(1:4)

  alter_pars <- joint_ms_set_vcov(
    object = model_ptr,
    vcov_vary = vcov_vary,
    vcov_surv = matrix(0,0,0))

  for(vcov in joint_ms_va_par(object = model_ptr, par = alter_pars))
    expect_equal(vcov$vcov,vcov_vary)

  expect_equal(
    joint_ms_format(object = model_ptr, par = alter_pars)$vcov$vcov_vary,
    vcov_vary)

  expect_snapshot_value(joint_ms_format(model_ptr,start_vals),
                        style = "serialize",
                        tolerance = 1e-3)

  fit <- joint_ms_opt(object = model_ptr, par = start_vals, gr_tol = .01)
  hess <- joint_ms_hess(object = model_ptr,par = fit$par)

  expect_snapshot_value(fit[c("value", "info", "convergence")],
                        tolerance = 1e-5)

  expect_snapshot_value(joint_ms_format(model_ptr, fit$par),
                        style = "serialize", tolerance = 1e-3)

  expect_snapshot_value(hess$hessian,
                        style = "serialize", tolerance = 1e-3)
  skip_on_cran()
  se <- 0.131148235758747
  which_prof <- model_ptr$indices$survival[[1]]$associations[1]
  delta <- 2*se

  profile_CI <- joint_ms_profile(
    object = model_ptr, opt_out = fit, which_prof = which_prof,
    delta= delta, gr_tol = .01, verbose = FALSE)

  expect_snapshot_value(profile_CI[c("confs","xs","p_log_Lik")],
                        style = "json2",
                        tolerance = 1e-3)
})

test_that("test manual page example for bs_term", {
  vals <- c(0.41, 0.29, 0.44, 0.1, 0.18, 0.65, 0.29, 0.85, 0.36, 0.47)
  spline_basis <- bs_term(vals,df = 3)

  library(splines)

    correct_basis <- bs(vals, df = 3)


  expect_equal(c(spline_basis$eval(0.5)),
                bs(0.5,Boundary.knots = attr(correct_basis, "Boundary.knots"),
                                           knots = attr(correct_basis,
                                                        "knots")),
               ignore_attr = TRUE)

  expect_equal(c(spline_basis$eval(0.5,der = 1)),
               c(-1.1199999999968, 0.853333333335853, 1.13777777777691),
               tolerance = 1e-6)
})

test_that("test manual page example for ns_term", {
  vals <- c(0.41, 0.29, 0.44, 0.1, 0.18, 0.65, 0.29, 0.85, 0.36, 0.47)
  spline_basis <- ns_term(vals,df = 3)

  library(splines)

  correct_basis <- ns(vals, df = 3)


  expect_equal(c(spline_basis$eval(0.5)),
               ns(0.5,Boundary.knots = attr(correct_basis, "Boundary.knots"),
                  knots = attr(correct_basis,
                               "knots")),
               ignore_attr = TRUE)

  expect_equal(c(spline_basis$eval(0.5,der = 1)),
               c(1.06750746213182, -0.889635441325693, 1.95627432066475),
               tolerance = 1e-6)
})

test_that("test manual page example for stacked_term", {
  vals <- c(0.41, 0.29, 0.44, 0.1, 0.18, 0.65, 0.29, 0.85, 0.36, 0.47)
  spline_basis1 <- ns_term(vals, df = 3)
  spline_basis2 <- bs_term(vals, df = 3)

  stacked_basis <- stacked_term(spline_basis1, spline_basis2)

  library(splines)

  correct_basis1 <- ns(vals, df = 3)
  correct_basis2 <- bs(vals, df = 3)

  expect_equal(
    c(stacked_basis$eval(0.5)),
    cbind(
      ns(
        0.5,Boundary.knots = attr(correct_basis1, "Boundary.knots"),
        knots = attr(correct_basis1, "knots")),
      bs(
        0.5,Boundary.knots = attr(correct_basis2, "Boundary.knots"),
        knots = attr(correct_basis2, "knots"))),
    ignore_attr = TRUE)

  expect_equal(c(stacked_basis$eval(0.5,der = 1)),
               c(1.06750746212726, -0.889635441332606, 1.95627432066876,
                 -1.12, 0.853333333333333, 1.13777777777778),
               tolerance = 1e-6)
})

test_that("test manual page example for weighted_term", {
  vals <- c(0.41, 0.29, 0.44, 0.1, 0.18, 0.65, 0.29, 0.85, 0.36, 0.47)
  ws <- c(4,5)
  basis <- ns_term(vals, df = 3)
  weighted_basis <- weighted_term(basis, weights)

  library(splines)

  correct_basis <- ns(vals, df = 3)


  expect_equal(
    c(t(weighted_basis$eval(c(0.5, 0.7), newdata = data.frame(weights = ws)))),
    ns(
      c(0.5, 0.7), Boundary.knots = attr(correct_basis, "Boundary.knots"),
      knots = attr(correct_basis, "knots"))*rep(ws, 3),
    ignore_attr = TRUE)

  expect_equal(c(weighted_basis$eval(c(0.5,0.7), newdata = data.frame(weights = ws),der = 1)),
               c(4.27002984850904, -3.55854176533042, 7.82509728267505,
                 -12.1889695326034, 0.47409899023935, 13.6748008559529),
               tolerance = 1e-6)
})

test_that("plot_marker returns same type of output", {
  # load in the data
  library(survival)
  data(pbc, package = "survival")

  # re-scale by year
  pbcseq <- transform(pbcseq, day_use = day / 365.25)
  pbc <- transform(pbc, time_use = time / 365.25)

  # create the marker terms
  m1 <- marker_term(
    log(bili) ~ 1, id = id, data = pbcseq,
    time_fixef = bs_term(day_use, df = 5L),
    time_rng = poly_term(day_use, degree = 1L, raw = TRUE, intercept = TRUE))

  fixef_vary <- c(-0.1048, 0.2583, 1.0578, 2.4006, 2.9734)
  vcov_vary <- rbind(c(0.96580, 0.09543), c(0.09543,  0.03998))

  # plot marker's trajectory
  marker_plot <- plot_marker(
    time_fixef = m1$time_fixef,
    time_rng = m1$time_rng,
    fixef_vary = fixef_vary,
    vcov_vary = vcov_vary, x_range = c(0,5))

  expect_snapshot_value(marker_plot, style = "serialize")
})

test_that("plot_surv returns same type of output", {
  # load in the data
  library(survival)
  data(pbc, package = "survival")

  # re-scale by year
  pbcseq <- transform(pbcseq, day_use = day / 365.25)
  pbc <- transform(pbc, time_use = time / 365.25)

  # create the marker terms
  m1 <- marker_term(
    log(bili) ~ 1, id = id, data = pbcseq,
    time_fixef = bs_term(day_use, df = 5L),
    time_rng = poly_term(day_use, degree = 1L, raw = TRUE, intercept = TRUE))
  m2 <- marker_term(
    albumin ~ 1, id = id, data = pbcseq,
    time_fixef = bs_term(day_use, df = 5L),
    time_rng = poly_term(day_use, degree = 1L, raw = TRUE, intercept = TRUE))

  # base knots on observed event times
  bs_term_knots <-
    with(pbc, quantile(time_use[status == 2], probs = seq(0, 1, by = .2)))

  boundary <- c(bs_term_knots[ c(1, length(bs_term_knots))])
  interior <- c(bs_term_knots[-c(1, length(bs_term_knots))])

  # create the survival term
  s_term <- surv_term(
    Surv(time_use, status == 2) ~ 1, id = id, data = pbc,
    time_fixef = bs_term(time_use, Boundary.knots = boundary, knots = interior))

  # expansion of time for the fixed effects in the survival term
  time_fixef <- s_term$time_fixef
  # expansion of time for the random effects in the marker terms
  time_rng <- list(m1$time_rng, m2$time_rng)
  # no frailty
  frailty_var <- matrix(0L,1)
  # var-covar matrix for time-varying random effects
  vcov_vary <- c(0.9658, 0.0954, -0.1756, -0.0418, 0.0954, 0.04, -0.0276,
                 -0.0128, -0.1756, -0.0276, 0.1189, 0.0077, -0.0418, -0.0128,
                 0.0077, 0.0057) |> matrix(4L)
  # coefficients for time-varying fixed effects
  fixef_vary <- c(1.0495, -0.2004, 1.4167, 1.255, 2.5007, 4.8545, 4.7889)
  # association parameters
  associations <- c(0.8627, -3.2358, 0.1842)
  # constant shift on the log-hazard scale
  log_hazard_shift <- -4.498513
  # specify how the survival outcome is linked with markers
  ders = list(0L, c(0L, -1L))

  # plot the hazard with pointwise quantiles
  plot_out <- plot_surv(
    time_fixef = time_fixef,
    time_rng = time_rng,
    x_range = c(0, 5), vcov_vary = vcov_vary, frailty_var = frailty_var,
    ps = c(.25, .5, .75), log_hazard_shift = log_hazard_shift,
    fixef_vary = fixef_vary, associations = associations, ders = ders)

  expect_snapshot_value(plot_out,
                        style = "serialize")
})