tests/testthat/helpers/helpers.R

In csetraynor/mctte: Compartmental models applied to time-to-event.

# Code obtained from 'rstanarm' under GNU 3.0 license

# Use the standard errors from a fitted 'comparison model' to obtain 
# the tolerance for each parameter in the joint model
# Obtain parameter specific tolerances that can be used to assess the 
# accuracy of parameter estimates in stan_jm models. The tolerances
# are calculated by taking the SE/SD for the parameter estimate in a 
# "gold standard" model and multiplying this by the relevant element 
# in the 'tolscales' argument.
#
# @param mod The "gold standard" longitudinal model. Likely to be
#   a model estimated using coxph.
# @param toscales A named list with elements 'hr_fixef' and 'tde_fixef'.
#
get_tols <- function(mod, tolscales) {
  
  cl <- class(mod)[1L]
  
  if (cl %in% c("coxph", "survreg")) {
    fixef_ses  <- sqrt(diag(mod$var))[1:length(mod$coefficients)]
    fixef_tols <- tolscales$hr_fixef * fixef_ses
    names(fixef_tols) <- names(mod$coefficients)
  }
  
  if ("(Intercept)" %in% names(fixef_tols))
    fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]]
  
  ret <- Filter(function(x) !is.null(x), list(fixef = fixef_tols))
  
  return(ret)
}

# Suppress warnings
SW <- function(expr) capture.output(suppressWarnings(expr))

# Expect object
expect_stanmctte <- function(x) expect_s3_class(x, "stanmctte")

# Expect object
expect_posterior <- function(x) expect_s3_class(x, "posterior_mcfit.stanmctte")

# Expect object
expect_plot <- function(x) expect_s3_class(x, "ggplot")


# Recover parameter estimates and return a list with consistent
# parameter names for comparing stan_surv and coxph estimates
#
# @param mod The fitted survival model. Likely to be a model estimated 
#   using either coxph or stan_surv.
#
recover_pars <- function(mod) {
  
  cl <- class(mod)[1L]
  
  fixef_pars <- switch(cl,
                       coxph    = mod$coefficients,
                       survreg  = mod$coefficients,
                       stanmctte = fixef(mod),
                       NULL)
  
  ret <- Filter(function(x) !is.null(x), list(fixef = fixef_pars))
  
  return(ret)
}