Merge branch 'main' into 160_backticks

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: cardx
 Title: Extra Analysis Results Data Utilities
-Version: 0.1.0.9057
+Version: 0.1.0.9058
 Authors@R: c(
     person("Daniel", "Sjoberg", , "[email protected]", role = c("aut", "cre")),
     person("Abinaya", "Yogasekaram", , "[email protected]", role = "aut"),

NEWS.md

@@ -1,4 +1,4 @@
-# cardx 0.1.0.9057
+# cardx 0.1.0.9058
 
 ### Breaking Changes
 

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
+}

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))
+

tests/testthat/test-construction_helpers.R

@@ -116,4 +116,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())
+      )
+    }
+  )
 })