added construct_model.survey.design() method (#128)

**What changes are proposed in this pull request?**
* Style this entry in a way that can be copied directly into `NEWS.md`.
(#<issue number>, @<username>)

Provide more detail here as needed.

**Reference GitHub issue associated with pull request.** _e.g., 'closes
#<issue number>'_



--------------------------------------------------------------------------------

Pre-review Checklist (if item does not apply, mark is as complete)
- [ ] **All** GitHub Action workflows pass with a ✅
- [ ] PR branch has pulled the most recent updates from master branch:
`usethis::pr_merge_main()`
- [ ] If a bug was fixed, a unit test was added.
- [ ] If a new `ard_*()` function was added, it passes the ARD
structural checks from `cards::check_ard_structure()`.
- [ ] If a new `ard_*()` function was added, `set_cli_abort_call()` has
been set.
- [ ] If a new `ard_*()` function was added and it depends on another
package (such as, `broom`), `is_pkg_installed("broom", reference_pkg =
"cardx")` has been set in the function call and the following added to
the roxygen comments: `@examplesIf
do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"",
reference_pkg = "cardx"))`
- [ ] Code coverage is suitable for any new functions/features
(generally, 100% coverage for new code): `devtools::test_coverage()`

Reviewer Checklist (if item does not apply, mark is as complete)

- [ ] If a bug was fixed, a unit test was added.
- [ ] Code coverage is suitable for any new functions/features:
`devtools::test_coverage()`

When the branch is ready to be merged:
- [ ] Update `NEWS.md` with the changes from this pull request under the
heading "`# cardx (development version)`". If there is an issue
associated with the pull request, reference it in parentheses at the end
update (see `NEWS.md` for examples).
- [ ] **All** GitHub Action workflows pass with a ✅
- [ ] Approve Pull Request
- [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge".

Author: ddsjoberg

NAMESPACE

@@ -4,6 +4,7 @@ S3method(ard_regression,default)
 S3method(ard_stats_anova,anova)
 S3method(ard_stats_anova,data.frame)
 S3method(construct_model,data.frame)
+S3method(construct_model,survey.design)
 export("%>%")
 export(all_of)
 export(any_of)

R/construction_helpers.R

@@ -13,8 +13,10 @@
 #'
 #' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick.
 #'
-#' @param x (`data.frame`)\cr
-#'   a data frame
+#' @param x
+#'  - `construct_model.data.frame()` (`data.frame`) a data frame
+#'  - `construct_model.survey.design()` (`survey.design`) a survey design object
+#'  - `bt()`/`bt_strip()` (`character`) character vector, typically of variable names
 #' @param formula (`formula`)\cr
 #'   a formula
 #' @param method (`string`)\cr
@@ -26,8 +28,6 @@
 #' @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.
@@ -80,7 +80,7 @@ construct_model.data.frame <- function(x, formula, method, method.args = list(),
   check_not_namespaced(method)
 
   # convert method.args to list of expressions (to account for NSE inputs) -----
-  method.args <- call_args(enexpr(method.args))
+  method.args <- .as_list_of_exprs({{ method.args }})
 
   # build model ----------------------------------------------------------------
   withr::with_namespace(
@@ -90,6 +90,36 @@ construct_model.data.frame <- function(x, formula, method, method.args = list(),
   )
 }
 
+#' @rdname construction_helpers
+#' @export
+construct_model.survey.design <- function(x, formula, method, method.args = list(), package = "survey", 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 <- .as_list_of_exprs({{ method.args }})
+
+  # build model ----------------------------------------------------------------
+  withr::with_namespace(
+    package = package,
+    call2(.fn = method, formula = formula, design = x, !!!method.args) |>
+      eval_tidy(env = env)
+  )
+}
+
+.as_list_of_exprs <- function(x) {
+  call_args(enexpr(x))
+}
+
 #' @rdname construction_helpers
 #' @export
 reformulate2 <- function(termlabels, response = NULL, intercept = TRUE,

man/construction_helpers.Rd

@@ -1,3 +1,5 @@
+skip_if_not(is_pkg_installed(c("withr", "survey"), reference_pkg = "cardx"))
+
 test_that("construct_model() works", {
   expect_snapshot(
     construct_model(
@@ -27,4 +29,23 @@ test_that("construct_model() works", {
     check_not_namespaced("geepack::geeglm"),
     "cannot be namespaced"
   )
+
+  # now the survey method -------
+  # styler: off
+  expect_equal({
+    data(api, package = "survey")
+    # stratified sample
+    survey::svydesign(id = ~1, strata = ~stype, weights = ~pw, data = apistrat, fpc = ~fpc) |>
+      construct_model(formula = api00 ~ api99, method = "svyglm") |>
+      ard_regression() |>
+      cards::get_ard_statistics(stat_name %in% "estimate")},
+    survey::svyglm(
+      api00 ~ api99,
+      design = survey::svydesign(id = ~1, strata = ~stype, weights = ~pw, data = apistrat, fpc = ~fpc)
+    ) |>
+      coef() |>
+      getElement(2L) |>
+      list(estimate = _)
+  )
+  # styler: on
 })