Add same error to survey design construction helper

insightsengineering · Jun 30, 2024 · 7ccb3fa · 7ccb3fa
1 parent 6110b0c
commit 7ccb3fa
Show file tree

Hide file tree

Showing 3 changed files with 103 additions and 4 deletions.
diff --git a/R/construction_helpers.R b/R/construction_helpers.R
@@ -131,10 +131,25 @@ construct_model.survey.design <- function(data, formula, method, method.args = l
   method.args <- .as_list_of_exprs({{ method.args }})
 
   # build model ----------------------------------------------------------------
-  withr::with_namespace(
-    package = package,
-    call2(.fn = method, formula = formula, design = data, !!!method.args) |>
-      eval_tidy(env = env)
+  call_to_run <- call2(.fn = method, formula = formula, design = data, !!!method.args)
+
+  try_fetch(
+    withr::with_namespace(
+      package = package,
+      eval_tidy(call_to_run, env = env)
+    ),
+    error = function(e) {
+      msg <- "There was an error evaluating the model"
+      if (is_string(method)) {
+        msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
+      }
+
+      cli::cli_abort(
+        message = msg,
+        parent = e,
+        call = get_cli_abort_call()
+      )
+    }
   )
 }
 

diff --git a/tests/testthat/_snaps/construction_helpers.md b/tests/testthat/_snaps/construction_helpers.md
@@ -52,3 +52,59 @@
       Caused by error in `glm.control()`:
       ! unused argument (iamnotavalidparameter = "binomial")
 
+---
+
+    Code
+      data(api, package = "survey")
+      design <- survey::svydesign(id = ~1, weights = ~pw, data = apistrat)
+      construct_model(data = design, formula = api00 ~ api99, method = survey::svyglm,
+      method.args = list(iamnotavalidparameter = stats::gaussian()))
+    Condition
+      Error in `construct_model()`:
+      ! There was an error evaluating the model
+      Caused by error in `glm.control()`:
+      ! unused argument (iamnotavalidparameter = list("gaussian", "identity", function (mu) 
+      mu, function (eta) 
+      eta, function (mu) 
+      rep.int(1, length(mu)), function (y, mu, wt) 
+      wt * ((y - mu)^2), function (y, n, mu, wt, dev) 
+      {
+          nobs <- length(y)
+          nobs * (log(dev/nobs * 2 * pi) + 1) + 2 - sum(log(wt))
+      }, function (eta) 
+      rep.int(1, length(eta)), expression({
+          n <- rep.int(1, nobs)
+          if (is.null(etastart) && is.null(start) && is.null(mustart) && ((family$link == "inverse" && any(y == 0)) || (family$link == "log" && any(y <= 0)))) stop("cannot find valid starting values: please specify some")
+          mustart <- y
+      }), function (mu) 
+      TRUE, function (eta) 
+      TRUE, NA))
+
+---
+
+    Code
+      data(api, package = "survey")
+      design <- survey::svydesign(id = ~1, weights = ~pw, data = apistrat)
+      construct_model(data = design, formula = api00 ~ api99, method = "svyglm",
+      method.args = list(iamnotavalidparameter = stats::gaussian()))
+    Condition
+      Error in `construct_model()`:
+      ! There was an error evaluating the model `svyglm(formula = api00 ~ api99, design = structure(list(cluster = structure(list( id = 1:200), c ...`
+      Caused by error in `glm.control()`:
+      ! unused argument (iamnotavalidparameter = list("gaussian", "identity", function (mu) 
+      mu, function (eta) 
+      eta, function (mu) 
+      rep.int(1, length(mu)), function (y, mu, wt) 
+      wt * ((y - mu)^2), function (y, n, mu, wt, dev) 
+      {
+          nobs <- length(y)
+          nobs * (log(dev/nobs * 2 * pi) + 1) + 2 - sum(log(wt))
+      }, function (eta) 
+      rep.int(1, length(eta)), expression({
+          n <- rep.int(1, nobs)
+          if (is.null(etastart) && is.null(start) && is.null(mustart) && ((family$link == "inverse" && any(y == 0)) || (family$link == "log" && any(y <= 0)))) stop("cannot find valid starting values: please specify some")
+          mustart <- y
+      }), function (mu) 
+      TRUE, function (eta) 
+      TRUE, NA))
+
diff --git a/tests/testthat/test-construction_helpers.R b/tests/testthat/test-construction_helpers.R
@@ -131,4 +131,32 @@ test_that("construct_model() messaging", {
       method.args = list(iamnotavalidparameter = "binomial")
     )
   )
+
+  expect_snapshot(
+    error = TRUE,
+    {
+      data(api, package = "survey")
+      design <- survey::svydesign(id = ~1, weights = ~pw, data = apistrat)
+      construct_model(
+        data = design,
+        formula = api00 ~ api99,
+        method = survey::svyglm,
+        method.args = list(iamnotavalidparameter = stats::gaussian())
+      )
+    }
+  )
+
+  expect_snapshot(
+    error = TRUE,
+    {
+      data(api, package = "survey")
+      design <- survey::svydesign(id = ~1, weights = ~pw, data = apistrat)
+      construct_model(
+        data = design,
+        formula = api00 ~ api99,
+        method = "svyglm",
+        method.args = list(iamnotavalidparameter = stats::gaussian())
+      )
+    }
+  )
 })