Adding model construction helpers

NAMESPACE

@@ -3,6 +3,7 @@
 S3method(ard_regression,default)
 S3method(ard_stats_anova,anova)
 S3method(ard_stats_anova,data.frame)
+S3method(construct_model,data.frame)
 export("%>%")
 export(all_of)
 export(any_of)
@@ -36,6 +37,9 @@ export(ard_survey_svyranktest)
 export(ard_survey_svyttest)
 export(ard_survival_survdiff)
 export(ard_survival_survfit)
+export(bt)
+export(bt_strip)
+export(construct_model)
 export(contains)
 export(ends_with)
 export(everything)
@@ -49,6 +53,7 @@ export(proportion_ci_jeffreys)
 export(proportion_ci_strat_wilson)
 export(proportion_ci_wald)
 export(proportion_ci_wilson)
+export(reformulate2)
 export(starts_with)
 export(where)
 import(rlang)

R/ard_stats_anova.R

@@ -10,21 +10,13 @@
 #'   a data frame
 #' @param formulas (`list`)\cr
 #'   a list of formulas
-#' @param fn (`string`)\cr
-#'   string naming the function to be called, e.g. `"glm"`.
-#'   If function belongs to a library that is not attached, the package name
-#'   must be specified in the `package` argument.
-#' @param fn.args (named `list`)\cr
-#'   named list of arguments that will be passed to `fn`.
-#' @param package (`string`)\cr
-#'   string of package name that will be temporarily loaded when function
-#'   specified in `method` is executed.
-#' @param method (`string`)\cr
+#' @param method_text (`string`)\cr
 #'   string of the method used. Default is `"ANOVA results from `stats::anova()`"`.
 #'   We provide the option to change this as `stats::anova()` can produce
 #'   results from many types of models that may warrant a more precise
 #'   description.
 #' @inheritParams rlang::args_dots_empty
+#' @inheritParams construction_helpers
 #'
 #' @details
 #' When a list of formulas is supplied to `ard_stats_anova()`, these formulas
@@ -34,12 +26,12 @@
 #' The models are constructed using `rlang::exec()`, which is similar to `do.call()`.
 #'
 #' ```r
-#' rlang::exec(.fn = fn, formula = formula, data = data, !!!fn.args)
+#' rlang::exec(.fn = method, formula = formula, data = data, !!!method.args)
 #' ```
 #'
 #' The above function is executed in `withr::with_namespace(package)`, which
-#' allows for the use of `ard_stats_anova(fn)` from packages,
-#' e.g. `package = 'lme4'` must be specified when `fn = 'glmer'`.
+#' allows for the use of `ard_stats_anova(method)` from packages,
+#' e.g. `package = 'lme4'` must be specified when `method = 'glmer'`.
 #' See example below.
 #'
 #' @return ARD data frame
@@ -55,15 +47,15 @@
 #' ard_stats_anova(
 #'   x = mtcars,
 #'   formulas = list(am ~ mpg, am ~ mpg + hp),
-#'   fn = "glm",
-#'   fn.args = list(family = binomial)
+#'   method = "glm",
+#'   method.args = list(family = binomial)
 #' )
 #'
 #' ard_stats_anova(
 #'   x = mtcars,
 #'   formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)),
-#'   fn = "glmer",
-#'   fn.args = list(family = binomial),
+#'   method = "glmer",
+#'   method.args = list(family = binomial),
 #'   package = "lme4"
 #' )
 NULL
@@ -76,60 +68,52 @@ ard_stats_anova <- function(x, ...) {
 
 #' @rdname ard_stats_anova
 #' @export
-ard_stats_anova.anova <- function(x, method = "ANOVA results from `stats::anova()`", ...) {
+ard_stats_anova.anova <- function(x, method_text = "ANOVA results from `stats::anova()`", ...) {
   set_cli_abort_call()
 
   # check inputs ---------------------------------------------------------------
   check_dots_empty()
   check_pkg_installed("broom", reference_pkg = "cardx")
-  check_string(method, message = "Argument {.arg method} must be a string of a function name.")
+  check_string(method_text)
 
   # return df in cards formats -------------------------------------------------
   lst_results <-
     cards::eval_capture_conditions(
-      .anova_tidy_and_reshape(x, method = method)
+      .anova_tidy_and_reshape(x, method_text = method_text)
     )
 
   # final tidying up of cards data frame ---------------------------------------
-  .anova_final_ard_prep(lst_results, method = method)
+  .anova_final_ard_prep(lst_results, method_text = method_text)
 }
 
 
 #' @rdname ard_stats_anova
 #' @export
 ard_stats_anova.data.frame <- function(x,
                                        formulas,
-                                       fn,
-                                       fn.args = list(),
+                                       method,
+                                       method.args = list(),
                                        package = "base",
-                                       method = "ANOVA results from `stats::anova()`",
+                                       method_text = "ANOVA results from `stats::anova()`",
                                        ...) {
   set_cli_abort_call()
 
   # check inputs ---------------------------------------------------------------
   check_dots_empty()
-  check_string(package)
   check_pkg_installed(c("broom", "withr", package), reference_pkg = "cardx")
   check_not_missing(formulas)
-  check_not_missing(x)
-  check_not_missing(fn)
-  check_string(method, message = "Argument {.arg method} must be a string of a function name.")
-  check_data_frame(x)
-  check_string(fn)
-  if (str_detect(fn, "::")) {
-    cli::cli_abort(
-      c(
-        "Argument {.arg fn} cannot be namespaced.",
-        i = "Put the package name in the {.arg package} argument."
-      ),
-      call = get_cli_abort_call()
+  check_class(formulas, cls = "list")
+  walk(
+    formulas,
+    ~ check_class(
+      .x,
+      cls = "formula",
+      arg_name = "formulas",
+      message = "Each element of {.arg formulas} must be class {.cls formula}"
     )
-  }
+  )
 
   # calculate results and return df in cards formats ---------------------------
-  # process fn.args argument
-  fn.args <- rlang::call_args(rlang::enexpr(fn.args))
-
   # create models
   lst_results <-
     cards::eval_capture_conditions({
@@ -138,24 +122,20 @@ ard_stats_anova.data.frame <- function(x,
         lapply(
           formulas,
           function(formula) {
-            withr::with_namespace(
-              package = package,
-              call2(.fn = fn, formula = formula, data = x, !!!fn.args) |>
-                eval_tidy()
-            )
+            construct_model(x = x, formula = formula, method = method, method.args = {{ method.args }}, package = package)
           }
         )
 
       # now calculate `stats::anova()` and reshape results
       rlang::inject(stats::anova(!!!models)) |>
-        .anova_tidy_and_reshape(method = method)
+        .anova_tidy_and_reshape(method_text = method_text)
     })
 
   # final tidying up of cards data frame ---------------------------------------
-  .anova_final_ard_prep(lst_results, method = method)
+  .anova_final_ard_prep(lst_results, method_text = method_text)
 }
 
-.anova_tidy_and_reshape <- function(x, method) {
+.anova_tidy_and_reshape <- function(x, method_text) {
   broom::tidy(x) |>
     dplyr::mutate(
       across(everything(), as.list),
@@ -174,13 +154,13 @@ ard_stats_anova.data.frame <- function(x,
         dplyr::filter(., dplyr::n() == dplyr::row_number()) |>
           dplyr::mutate(
             stat_name = "method",
-            stat = list(.env$method)
+            stat = list(.env$method_text)
           )
       )
     }
 }
 
-.anova_final_ard_prep <- function(lst_results, method) {
+.anova_final_ard_prep <- function(lst_results, method_text) {
   # saving the results in data frame -------------------------------------------
   df_card <-
     if (!is.null(lst_results[["result"]])) {
@@ -189,7 +169,7 @@ ard_stats_anova.data.frame <- function(x,
       dplyr::tibble(
         variable = "model_1",
         stat_name = c("p.value", "method"),
-        stat = list(NULL, method)
+        stat = list(NULL, method_text)
       )
     }
 

R/ard_survey_svychisq.R

@@ -50,7 +50,7 @@ ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) {
       cards::tidy_as_ard(
         lst_tidy =
           cards::eval_capture_conditions(
-            survey::svychisq(stats::reformulate(termlabels = paste(variable, by, sep = "+"), response = NULL), design = data, statistic = statistic, ...) |>
+            survey::svychisq(reformulate2(termlabels = c(variable, by)), design = data, statistic = statistic, ...) |>
               broom::tidy()
           ),
         tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),

R/construction_helpers.R

@@ -0,0 +1,146 @@
+#' Construction Helpers
+#'
+#' These functions help construct calls to various types of models.
+#'
+#' - `construct_model()`: Builds models of the form `method(data = data, formula = formula, method.args!!!)`.
+#'    If the `package` argument is specified, that package is temporarily attached
+#'    when the model is evaluated.
+#'
+#' - `reformulate2()`: This is a copy of `reformulate()` except that variable
+#'    names that contain a space are wrapped in backticks.
+#'
+#' - `bt()`: Adds backticks to a character vector.
+#'
+#' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick.
+#'
+#' @param x (`data.frame`)\cr
+#'   a data frame
+#' @param formula (`formula`)\cr
+#'   a formula
+#' @param method (`string`)\cr
+#'   string naming the function to be called, e.g. `"glm"`.
+#'   If function belongs to a library that is not attached, the package name
+#'   must be specified in the `package` argument.
+#' @param method.args (named `list`)\cr
+#'   named list of arguments that will be passed to `fn`.
+#' @param package (`string`)\cr
+#'   string of package name that will be temporarily loaded when function
+#'   specified in `method` is executed.
+#' @param x (`character`)\cr
+#'   character vector, typically of variable names
+#' @param pattern (`string`)\cr
+#'   regular expression string. If the regex matches, backticks are added
+#'   to the string. When `NULL`, backticks are not added.
+#' @param pattern_term,pattern_response passed to `bt(pattern)` for arguments
+#'   `stats::reformulate(termlabels, response)`.
+#' @inheritParams rlang::eval_tidy
+#' @inheritParams stats::reformulate
+#' @inheritParams rlang::args_dots_empty
+#'
+#' @return depends on the calling function
+#' @name construction_helpers
+#'
+#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx"))
+#' construct_model(
+#'   x = mtcars,
+#'   formula = am ~ mpg + (1 | vs),
+#'   method = "glmer",
+#'   method.args = list(family = binomial),
+#'   package = "lme4"
+#' )
+#'
+#' construct_model(
+#'   x = mtcars |> dplyr::rename(`M P G` = mpg),
+#'   formula = reformulate2(c("M P G", "cyl"), response = "hp"),
+#'   method = "lm"
+#' ) |>
+#'   ard_regression() |>
+#'   dplyr::filter(stat_name %in% c("term", "estimate", "p.value"))
+NULL
+
+#' @rdname construction_helpers
+#' @export
+construct_model <- function(x, ...) {
+  UseMethod("construct_model")
+}
+
+#' @rdname construction_helpers
+#' @export
+construct_model.data.frame <- function(x, formula, method, method.args = list(), package = "base", env = caller_env(), ...) {
+  set_cli_abort_call()
+  # check pkg installations ----------------------------------------------------
+  check_dots_empty()
+  check_pkg_installed(c("withr", package), reference_pkg = "cardx")
+
+  check_not_missing(formula)
+  check_class(formula, cls = "formula")
+
+  check_not_missing(method)
+  check_string(method)
+  check_not_namespaced(method)
+
+  # convert method.args to list of expressions (to account for NSE inputs) -----
+  method.args <- call_args(enexpr(method.args))
+
+  # build model ----------------------------------------------------------------
+  withr::with_namespace(
+    package = package,
+    call2(.fn = method, formula = formula, data = x, !!!method.args) |>
+      eval_tidy(env = env)
+  )
+}
+
+#' @rdname construction_helpers
+#' @export
+reformulate2 <- function(termlabels, response = NULL, intercept = TRUE,
+                         pattern_term = "[ \n\r]", pattern_response = "[ \n\r]",
+                         env = parent.frame()) {
+  stats::reformulate(
+    termlabels = bt(termlabels, pattern_term),
+    response = bt(response, pattern_response),
+    intercept = intercept,
+    env = env
+  )
+}
+
+#' @rdname construction_helpers
+#' @export
+bt <- function(x, pattern = "[ \n\r]") {
+  if (is_empty(x)) {
+    return(x)
+  }
+  if (is_empty(pattern)) {
+    return(x)
+  }
+  ifelse(
+    str_detect(x, pattern = pattern),
+    paste0("`", x, "`"),
+    x
+  )
+}
+
+#' @rdname construction_helpers
+#' @export
+bt_strip <- function(x) {
+  ifelse(
+    str_detect(x, "^`.*`$"),
+    substr(x, 2, nchar(x) - 1),
+    x
+  )
+}
+
+check_not_namespaced <- function(x,
+                                 arg_name = rlang::caller_arg(x),
+                                 class = "check_not_namespaced",
+                                 call = get_cli_abort_call()) {
+  check_string(x, arg_name = arg_name, call = call, class = "check_not_namespaced")
+
+  if (str_detect(x, "::")) {
+    c("Argument {.arg {arg_name}} cannot be namespaced.",
+      i = "Put the package name in the {.arg package} argument."
+    ) |>
+      cli::cli_abort(call = call, class = class)
+  }
+
+  invisible(x)
+}

_pkgdown.yml

@@ -57,3 +57,4 @@ reference:
   - title: "Helpers"
   - contents:
       - proportion_ci
+      - construction_helpers

inst/WORDLIST

@@ -18,6 +18,7 @@ XG
 Xin
 agresti
 anova
+backtick
 cli
 clopper
 coull
@@ -27,6 +28,7 @@ funder
 jeffreys
 pearson
 pre
+quosures
 sd
 strat
 vif