Issue #372: Refactor formula dispatch

NAMESPACE

@@ -11,8 +11,8 @@ S3method(epidist_family_prior,default)
 S3method(epidist_family_prior,lognormal)
 S3method(epidist_family_reparam,default)
 S3method(epidist_family_reparam,gamma)
-S3method(epidist_formula,default)
-S3method(epidist_formula,epidist_latent_individual)
+S3method(epidist_formula_model,default)
+S3method(epidist_formula_model,epidist_latent_individual)
 S3method(epidist_model_prior,default)
 S3method(epidist_stancode,default)
 S3method(epidist_stancode,epidist_latent_individual)
@@ -27,6 +27,7 @@ export(epidist_family_model)
 export(epidist_family_prior)
 export(epidist_family_reparam)
 export(epidist_formula)
+export(epidist_formula_model)
 export(epidist_model_prior)
 export(epidist_prior)
 export(epidist_stancode)

R/defaults.R

@@ -11,19 +11,6 @@ epidist_validate.default <- function(data, ...) {
   )
 }
 
-#' Default method for defining a model specific formula
-#'
-#' @inheritParams epidist_formula
-#' @param ... Additional arguments passed to method.
-#' @family defaults
-#' @export
-epidist_formula.default <- function(data, ...) {
-  cli_abort(
-    "No epidist_formula method implemented for the class ", class(data), "\n",
-    "See methods(epidist_formula) for available methods"
-  )
-}
-
 #' Default method for defining model specific Stan code
 #'
 #' @inheritParams epidist_stancode

R/epidist-package.R

@@ -8,6 +8,6 @@
 #' @importFrom brms bf prior
 #' @importFrom checkmate assert_data_frame assert_names assert_integer
 #'   assert_true assert_factor assert_numeric
-#' @importFrom cli cli_abort cli_inform
+#' @importFrom cli cli_abort cli_inform cli_abort
 ## usethis namespace: end
 NULL

R/family.R

@@ -41,11 +41,8 @@ epidist_family_model <- function(data, family, ...) {
 #' @param ... Additional arguments passed to method.
 #' @family family
 #' @export
-epidist_family_model.default <- function(data, ...) {
-  cli_abort(
-    "No epidist_family_model method implemented for the class ", class(data),
-    "\n", "See methods(epidist_family_model) for available methods"
-  )
+epidist_family_model.default <- function(data, family, ...) {
+  return(family)
 }
 
 #' Reparameterise an `epidist` family to align `brms` and Stan

R/formula.R

@@ -0,0 +1,45 @@
+#' Define a model specific formula
+#'
+#' This function is used within [epidist()] to create the formula object passed
+#' to `brms`. It is unlikely that as a user you will need this function, but we
+#' export it nonetheless to be transparent about what exactly is happening
+#' inside of a call to [epidist()].
+#'
+#' @param data A `data.frame` containing line list data
+#' @param family Output of a call to `brms::brmsfamily()`
+#' @param formula As produced by [brms::brmsformula()]
+#' @param ... ...
+#'
+#' @family formula
+#' @export
+epidist_formula <- function(data, family, formula, ...) {
+  epidist_validate(data)
+  formula <- brms:::validate_formula(formula, data = data, family = family)
+  formula <- .make_intercepts_explicit(formula)
+  formula <- epidist_formula_model(data, formula)
+  # Using this here for checking purposes
+  bterms <- brms::brmsterms(formula)
+  brms:::validate_data(data, bterms)
+  return(formula)
+}
+
+#' The model-specific parts of an `epidist_formula()` call
+#'
+#' @inheritParams epidist_formula
+#' @param ... Additional arguments passed to method.
+#' @rdname epidist_family_model
+#' @family formula
+#' @export
+epidist_formula_model <- function(data, formula, ...) {
+  UseMethod("epidist_formula_model")
+}
+
+#' Default method for defining a model specific formula
+#'
+#' @inheritParams epidist_formula
+#' @param ... Additional arguments passed to method.
+#' @family formula
+#' @export
+epidist_formula_model.default <- function(data, formula, ...) {
+  return(formula)
+}

R/generics.R

@@ -11,21 +11,6 @@ epidist_validate <- function(data) {
   UseMethod("epidist_validate")
 }
 
-#' Define a model specific formula
-#'
-#' This function is used within [epidist()] to create the formula object passed
-#' to `brms`. It is unlikely that as a user you will need this function, but we
-#' export it nonetheless to be transparent about what exactly is happening
-#' inside of a call to [epidist()].
-#'
-#' @inheritParams epidist_validate
-#' @param ... Additional arguments passed to method.
-#' @family generics
-#' @export
-epidist_formula <- function(data, ...) {
-  UseMethod("epidist_formula")
-}
-
 #' Define model specific Stan code
 #'
 #' This function is used within [epidist()] to create any custom Stan code which

R/latent_individual.R

@@ -129,28 +129,21 @@ epidist_family_model.epidist_latent_individual <- function(
   return(custom_family)
 }
 
-#' Define a formula for the latent_individual model
+#' Define the model-specific component of an `epidist` custom formula
 #'
 #' @param data A `data.frame` containing line list data
-#' @param family The output of [epidist_family()]
 #' @param formula As produced by [brms::brmsformula()]
 #' @param ... ...
-#' @method epidist_formula epidist_latent_individual
+#' @method epidist_formula_model epidist_latent_individual
 #' @family latent_individual
 #' @export
-epidist_formula.epidist_latent_individual <- function(data, family, formula,
-                                                      ...) {
-  epidist_validate(data)
-  formula <- brms:::validate_formula(formula, data = data, family = family)
-  formula <- .make_intercepts_explicit(formula)
+epidist_formula_model.epidist_latent_individual <- function(
+  data, formula, ...
+) {
+  # data is only used to dispatch on
   formula <- stats::update(
     formula, delay | vreal(relative_obs_time, pwindow, swindow) ~ .
   )
-
-  # Using this here for checking purposes
-  bterms <- brms::brmsterms(formula)
-  brms:::validate_data(data, bterms)
-
   return(formula)
 }
 

_pkgdown.yml

@@ -49,6 +49,10 @@ reference:
   desc: Functions related to specifying custom `brms` families
   contents:
   - has_concept("family")
+- title: Formula
+  desc: Functions related to specifying custom `brms` formula
+  contents:
+  - has_concept("formula")
 - title: Priors
   desc: Functions for specifying prior distributions
   contents: