tests/testthat/helpers/getters.R

In stan-dev/projpred: Projection Predictive Feature Selection

# Extends an abbreviated family name to its long form (only for categorical and
# ordinal families):
get_fam_long <- function(fam_nm) {
  switch(fam_nm,
         brnll = "bernoulli",
         categ = "categorical",
         cumul = "cumulative",
         srtio = "sratio",
         crtio = "cratio",
         adcat = "acat",
         NA_character_)
}

# As get_fam_long(), but including the families from the traditional projection:
get_fam_long_full <- function(fam_nm) {
  switch(fam_nm,
         "gauss" = "gaussian",
         "binom" = "binomial",
         "poiss" = "poisson",
         get_fam_long(fam_nm))
}

get_f_cumul <- function(link_nm = link_str) {
  structure(list(family = "cumulative_rstanarm",
                 link = link_nm),
            class = "family")
}

# Standardize the left-hand side of a formula, i.e., get a slightly modified
# formula as well as the response variable names before and after any
# evaluations of special expressions:
stdize_lhs <- function(formul_crr) {
  formul_crr <- rm_cbind(formul_crr)
  formul_crr <- rm_addresp(formul_crr)
  y_nm_orig <- as.character(formul_crr)[2]
  y_nm <- gsub("\\(|\\)", "", y_nm_orig)
  return(nlist(fml = formul_crr, y_nm_orig, y_nm))
}

# A function to retrieve the formula from a fit (`fit_obj`):
get_formul_from_fit <- function(fit_obj) {
  formul_out <- formula(fit_obj)
  if (inherits(fit_obj, "brmsfit")) {
    formul_out <- formula(formul_out)
  }
  return(formul_out)
}

# A function to adapt a given dataset (`dat`) appropriately to a given formula
# (`formul_crr`):
get_dat_formul <- function(formul_crr, needs_adj, dat_crr = dat,
                           add_offs_dummy = FALSE, wobs_brms = NULL,
                           offs_brms = NULL) {
  if (needs_adj) {
    stdized_lhs <- stdize_lhs(formul_crr)
    dat_crr[[stdized_lhs$y_nm]] <- eval(str2lang(stdized_lhs$y_nm_orig),
                                        dat_crr)
  }
  if (add_offs_dummy) {
    # Needed in some latent projection cases where posterior_linpred.stanreg()
    # complains about `offs_col` not found, even though its argument `offset` is
    # used. The specific value doesn't matter:
    dat_crr$offs_col <- 42
  }
  if (!is.null(offs_brms)) {
    dat_crr$offs_col <- offs_brms
  }
  if (!is.null(wobs_brms)) {
    dat_crr$wobs_col <- wobs_brms
  }
  return(dat_crr)
}

# A function to adapt a given dataset (`dat`) appropriately to a given "test
# setup" (`tstsetup`):
get_dat <- function(tstsetup, dat_crr = dat, offs_ylat = offs_tst, ...) {
  dat_crr <- get_dat_formul(
    args_fit[[args_prj[[tstsetup]]$tstsetup_fit]]$formula,
    needs_adj = grepl("\\.spclformul", tstsetup), dat_crr = dat_crr, ...
  )
  if (args_prj[[tstsetup]]$prj_nm == "latent") {
    if (args_prj[[tstsetup]]$pkg_nm == "rstanarm" &&
        grepl("\\.with_offs\\.", tstsetup)) {
      dat_crr$projpred_internal_offs_stanreg <- offs_ylat
    }
    y_nm <- stdize_lhs(prjs[[tstsetup]]$refmodel$formula)$y_nm
    dat_crr[[y_nm]] <- rowMeans(prjs[[tstsetup]]$refmodel$ref_predfun(
      fit = prjs[[tstsetup]]$refmodel$fit, newdata = dat_crr, excl_offs = FALSE,
      mlvl_allrandom = getOption("projpred.mlvl_proj_ref_new", FALSE)
    ))
  }
  return(dat_crr)
}

# A function to get the elements which may be supplied to argument `penalty`:
get_penal_possbl <- function(formul_crr) {
  return(setdiff(colnames(model.matrix(formul_crr, data = dat)), "(Intercept)"))
}

# A function to get the name of a fitting function for a reference model:
get_fit_fun_nm <- function(args_fit_i) {
  switch(args_fit_i$pkg_nm,
         "rstanarm" = switch(args_fit_i$mod_nm,
                             "glm" = "stan_glm",
                             "glmm" = "stan_glmer",
                             "stan_gamm4"),
         "brms" = "brm",
         stop("Unknown `pkg_nm`."))
}

get_warn_wrhs_orhs <- function(tstsetup, weightsnew, offsetnew) {
  if ((is.null(weightsnew) && is.null(offsetnew)) ||
      !grepl("^brms\\.", tstsetup) || packageVersion("brms") < "2.20.6") {
    return(NA)
  } else {
    return("^Argument `[wo]rhs` is currently ignored\\.")
  }
}