R/brm_prior_archetype.R

In brms.mmrm: Bayesian MMRMs using 'brms'

#' @title Informative priors for fixed effects in archetypes
#' @export
#' @family priors
#' @description Create a `brms` prior for fixed effects in an archetype.
#' @section Prior labeling:
#'   Informative prior archetypes use a labeling scheme to assign priors
#'   to fixed effects. How it works:
#'
#'     1. First, assign the prior of each parameter a collection
#'       of labels from the data. This can be done manually or with
#'       successive calls to [brm_prior_label()].
#'     2. Supply the labeling scheme to [brm_prior_archetype()].
#'       [brm_prior_archetype()] uses attributes of the archetype
#'       to map labeled priors to their rightful parameters in the model.
#'
#'   For informative prior archetypes, this process is much more convenient
#'   and robust than manually calling [brms::set_prior()].
#'   However, it requires an understanding of how the labels of the priors
#'   map to parameters in the model. This mapping varies from archetype
#'   to archetype, and it is documented in the help pages of
#'   archetype-specific functions such as [brm_archetype_successive_cells()].
#' @return A `brms` prior object that you can supply to the `prior`
#'   argument of [brm_model()].
#' @param archetype An informative prior archetype generated by a function
#'   like [brm_archetype_successive_cells()].
#' @param label A data frame with one row per model parameter in the
#'   archetype and columns to indicate the mapping between priors
#'   and labels. Generate using [brm_prior_label()] or manually.
#'   See the examples and the informative prior archetypes vignette
#'   for details.
#' @examples
#' set.seed(0L)
#' data <- brm_simulate_outline(
#'   n_group = 2,
#'   n_patient = 100,
#'   n_time = 3,
#'   rate_dropout = 0,
#'   rate_lapse = 0
#' ) |>
#'   dplyr::mutate(response = rnorm(n = dplyr::n())) |>
#'   brm_simulate_continuous(names = c("biomarker1", "biomarker2")) |>
#'   brm_simulate_categorical(
#'     names = c("status1", "status2"),
#'     levels = c("present", "absent")
#'   )
#' archetype <- brm_archetype_successive_cells(data)
#' dplyr::distinct(data, group, time)
#' prior <- NULL |>
#'   brm_prior_label("normal(1, 1)", group = "group_1", time = "time_1") |>
#'   brm_prior_label("normal(1, 2)", group = "group_1", time = "time_2") |>
#'   brm_prior_label("normal(1, 3)", group = "group_1", time = "time_3") |>
#'   brm_prior_label("normal(2, 1)", group = "group_2", time = "time_1") |>
#'   brm_prior_label("normal(2, 2)", group = "group_2", time = "time_2") |>
#'   brm_prior_label("normal(2, 3)", group = "group_2", time = "time_3") |>
#'   brm_prior_archetype(archetype = archetype)
#' prior
#' class(prior)
brm_prior_archetype <- function(label, archetype) {
  brm_data_validate(archetype)
  assert(
    inherits(archetype, "brms_mmrm_archetype"),
    message = "archetype must be an informative prior archetype"
  )
  map <- attr(archetype, "brm_archetype_mapping")
  fields <- intersect(colnames(map), c("group", "subgroup", "time"))
  assert(
    label,
    is.data.frame(.),
    c("code", fields) %in% colnames(.),
    message = paste(
      "label must be a data frame or tibble with columns",
      "'code', 'group', and 'time' (and 'subgroup' if applicable)."
    )
  )
  for (field in fields) {
    assert(
      label[[field]] %in% unique(map[[field]]),
      message = paste(
        "Mismatch between the",
        field,
        "levels of the archetype vs the labeling scheme.",
        "Please ensure you are assigning the correct values of",
        "group and time (and subgroup if applicable) to",
        "label argument of brm_prior_archetype()."
      )
    )
  }
  if (!("variable" %in% colnames(label))) {
    label <- dplyr::inner_join(x = map, y = label, by = fields)
  }
  priors <- lapply(
    X = seq_len(nrow(label)),
    FUN = function(index) {
      brms::set_prior(
        prior = label$code[index],
        class = "b",
        coef = label$variable[index]
      )
    }
  )
  do.call(what = c, args = priors)
}