Rethrow error with additional context (#178)

**What changes are proposed in this pull request?** * A more user-friendly error message is now raised when a user misspecifies a model Before: ```r construct_model( data = mtcars,method = "glm", formula = am ~ cyl, method.args = list(fomily = "binomial")) #> Error in glm.control(fomily = "binomial") : #> unused argument (fomily = "binomial") ``` After: ```r construct_model( data = mtcars,method = "glm", formula = am ~ cyl, method.args = list(fomily = "binomial")) #> Error: #> ! There was an error evaluating model `glm(formula = am ~ cyl, data = ".", fomily = "bino ...`. #> Caused by error in `glm.control()`: #> ! unused argument (fomily = "binomial") #> Run `rlang::last_trace()` to see where the error occurred. ``` Closes #176 -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [x] **All** GitHub Action workflows pass with a ✅ - [x] PR branch has pulled the most recent updates from master branch: `usethis::pr_merge_main()` - [x] If a bug was fixed, a unit test was added. - [x] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`. - [x] If a new `ard_*()` function was added, `set_cli_abort_call()` has been set. - [x] 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"))` - [x] 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) - [x] If a bug was fixed, a unit test was added. - [x] Code coverage is suitable for any new functions/features: `devtools::test_coverage()` When the branch is ready to be merged: - [x] 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). - [x] **All** GitHub Action workflows pass with a ✅ - [x] Approve Pull Request - [x] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --------- Co-authored-by: Daniel Sjoberg <[email protected]>
insightsengineering · Jul 1, 2024 · cf3d14f · cf3d14f
1 parent 1cbf321
commit cf3d14f
Show file tree

Hide file tree

Showing 3 changed files with 175 additions and 8 deletions.
diff --git a/R/construction_helpers.R b/R/construction_helpers.R
@@ -90,10 +90,26 @@ construct_model.data.frame <- function(data, formula, method, method.args = list
   method.args <- .as_list_of_exprs({{ method.args }})
 
   # build model ----------------------------------------------------------------
-  withr::with_namespace(
-    package = package,
-    call2(.fn = method, formula = formula, data = data, !!!method.args) |>
-      eval_tidy(env = env)
+  call_to_run <- call2(.fn = method, formula = formula, data = 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)) {
+        call_to_run$data <- expr(.)
+        msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
+      }
+
+      cli::cli_abort(
+        message = msg,
+        parent = e,
+        call = get_cli_abort_call()
+      )
+    }
   )
 }
 
@@ -116,10 +132,26 @@ 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)) {
+        call_to_run$design <- expr(.)
+        msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
+      }
+
+      cli::cli_abort(
+        message = msg,
+        parent = e,
+        call = get_cli_abort_call()
+      )
+    }
   )
 }
 
@@ -212,3 +244,11 @@ check_string_or_function <- function(x,
 
   invisible(x)
 }
+
+truncate_call <- function(call, max_out = 100) {
+  call_text <- expr_text(call)
+  if (nchar(call_text) > max_out) {
+    call_text <- paste(substr(call_text, 1, max_out), "...")
+  }
+  call_text
+}
diff --git a/tests/testthat/_snaps/construction_helpers.md b/tests/testthat/_snaps/construction_helpers.md
@@ -30,3 +30,81 @@
       Error in `construct_model()`:
       ! Argument `method` must be a <string> or <function>.
 
+---
+
+    Code
+      construct_model(data = mtcars, method = "glm", formula = am ~ cyl, method.args = list(
+        iamnotavalidparameter = "binomial"))
+    Condition
+      Error in `construct_model()`:
+      ! There was an error evaluating the model `glm(formula = am ~ cyl, data = ., iamnotavalidparameter = "binomial")`
+      Caused by error in `glm.control()`:
+      ! unused argument (iamnotavalidparameter = "binomial")
+
+---
+
+    Code
+      construct_model(data = mtcars, method = glm, formula = am ~ cyl, method.args = list(
+        iamnotavalidparameter = "binomial"))
+    Condition
+      Error in `construct_model()`:
+      ! There was an error evaluating the model
+      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 = "svyglm",
+      method.args = list(iamnotavalidparameter = stats::gaussian()), package = "survey")
+    Condition
+      Error in `construct_model()`:
+      ! There was an error evaluating the model `svyglm(formula = api00 ~ api99, design = ., iamnotavalidparameter = stats::gaussian())`
+      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 = ., iamnotavalidparameter = stats::gaussian())`
+      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
@@ -111,4 +111,53 @@ test_that("construct_model() messaging", {
       formula = am ~ cyl
     )
   )
+
+  expect_snapshot(
+    error = TRUE,
+    construct_model(
+      data = mtcars,
+      method = "glm",
+      formula = am ~ cyl,
+      method.args = list(iamnotavalidparameter = "binomial")
+    )
+  )
+
+  expect_snapshot(
+    error = TRUE,
+    construct_model(
+      data = mtcars,
+      method = glm,
+      formula = am ~ cyl,
+      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 = "svyglm",
+        method.args = list(iamnotavalidparameter = stats::gaussian()),
+        package = "survey"
+      )
+    }
+  )
+
+  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())
+      )
+    }
+  )
 })