From 36e3860bb4bd93c73407eaaa7d36f36ea1c259c3 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 19 Apr 2024 16:40:42 -0700 Subject: [PATCH 1/2] added `construct_model.survey.design()` method --- NAMESPACE | 1 + R/construction_helpers.R | 40 +++++++++++++++++++--- man/construction_helpers.Rd | 18 ++++++++-- tests/testthat/test-construction_helpers.R | 19 ++++++++++ 4 files changed, 71 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 282c4efb4..a14d71b38 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/construction_helpers.R b/R/construction_helpers.R index 144f8a7cf..ae5873532 100644 --- a/R/construction_helpers.R +++ b/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, diff --git a/man/construction_helpers.Rd b/man/construction_helpers.Rd index fb00d9537..82d5439a3 100644 --- a/man/construction_helpers.Rd +++ b/man/construction_helpers.Rd @@ -4,6 +4,7 @@ \alias{construction_helpers} \alias{construct_model} \alias{construct_model.data.frame} +\alias{construct_model.survey.design} \alias{reformulate2} \alias{bt} \alias{bt_strip} @@ -21,6 +22,16 @@ construct_model(x, ...) ... ) +\method{construct_model}{survey.design}( + x, + formula, + method, + method.args = list(), + package = "survey", + env = caller_env(), + ... +) + reformulate2( termlabels, response = NULL, @@ -35,8 +46,11 @@ bt(x, pattern = "[ \\n\\r]") bt_strip(x) } \arguments{ -\item{x}{(\code{character})\cr -character vector, typically of variable names} +\item{x}{\itemize{ +\item \code{construct_model.data.frame()} (\code{data.frame}) a data frame +\item \code{construct_model.survey.design()} (\code{survey.design}) a survey design object +\item \code{bt()}/\code{bt_strip()} (\code{character}) character vector, typically of variable names +}} \item{...}{These dots are for future extensions and must be empty.} diff --git a/tests/testthat/test-construction_helpers.R b/tests/testthat/test-construction_helpers.R index 28490297e..589d22218 100644 --- a/tests/testthat/test-construction_helpers.R +++ b/tests/testthat/test-construction_helpers.R @@ -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,21 @@ test_that("construct_model() works", { check_not_namespaced("geepack::geeglm"), "cannot be namespaced" ) + + # now the survey method ------- + 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 = _) + ) }) From 2fe3813686d0556d7173d82e3e8399b7de381c58 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 19 Apr 2024 16:44:13 -0700 Subject: [PATCH 2/2] Update test-construction_helpers.R --- tests/testthat/test-construction_helpers.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-construction_helpers.R b/tests/testthat/test-construction_helpers.R index 589d22218..c8ed0fb2e 100644 --- a/tests/testthat/test-construction_helpers.R +++ b/tests/testthat/test-construction_helpers.R @@ -31,6 +31,7 @@ test_that("construct_model() works", { ) # now the survey method ------- + # styler: off expect_equal({ data(api, package = "survey") # stratified sample @@ -46,4 +47,5 @@ test_that("construct_model() works", { getElement(2L) |> list(estimate = _) ) + # styler: on })