set call in internal model registration errors (#807)

* set `call = NULL` in internal model registration errors

* pass caller env to erroring fns

* `expect_error` -> `expect_snapshot` + a few more tests

also want to test that we call out the right caller env when users use the drob interface ;)

Author: simonpcouch

R/aaa_models.R

@@ -163,7 +163,7 @@ check_mode_val <- function(mode) {
 }
 
 
-stop_incompatible_mode <- function(spec_modes, eng = NULL, cls = NULL) {
+stop_incompatible_mode <- function(spec_modes, eng = NULL, cls = NULL, call) {
   if (is.null(eng) & is.null(cls)) {
     msg <- "Available modes are: "
   }
@@ -181,18 +181,18 @@ stop_incompatible_mode <- function(spec_modes, eng = NULL, cls = NULL) {
     msg,
     glue::glue_collapse(glue::glue("'{spec_modes}'"), sep = ", ")
   )
-  rlang::abort(msg)
+  rlang::abort(msg, call = call)
 }
 
-stop_incompatible_engine <- function(spec_engs, mode) {
+stop_incompatible_engine <- function(spec_engs, mode, call) {
   msg <- glue::glue(
     "Available engines for mode {mode} are: ",
     glue::glue_collapse(glue::glue("'{spec_engs}'"), sep = ", ")
   )
-  rlang::abort(msg)
+  rlang::abort(msg, call = call)
 }
 
-stop_missing_engine <- function(cls) {
+stop_missing_engine <- function(cls, call) {
   info <-
     get_from_env(cls) %>%
     dplyr::group_by(mode) %>%
@@ -201,11 +201,11 @@ stop_missing_engine <- function(cls) {
                                   "}"),
                      .groups = "drop")
   if (nrow(info) == 0) {
-    rlang::abort(paste0("No known engines for `", cls, "()`."))
+    rlang::abort(paste0("No known engines for `", cls, "()`."), call = call)
   }
   msg <- paste0(info$msg, collapse = ", ")
   msg <- paste("Missing engine. Possible mode/engine combinations are:", msg)
-  rlang::abort(msg)
+  rlang::abort(msg, call = call)
 }
 
 check_mode_for_new_engine <- function(cls, eng, mode) {
@@ -218,11 +218,12 @@ check_mode_for_new_engine <- function(cls, eng, mode) {
 
 
 # check if class and mode and engine are compatible
-check_spec_mode_engine_val <- function(cls, eng, mode) {
+check_spec_mode_engine_val <- function(cls, eng, mode, call = caller_env()) {
 
   all_modes <- get_from_env(paste0(cls, "_modes"))
   if (!(mode %in% all_modes)) {
-    rlang::abort(paste0("'", mode, "' is not a known mode for model `", cls, "()`."))
+    rlang::abort(paste0("'", mode, "' is not a known mode for model `", cls, "()`."),
+                 call = call)
   }
 
   model_info <- rlang::env_get(get_model_env(), cls)
@@ -237,7 +238,7 @@ check_spec_mode_engine_val <- function(cls, eng, mode) {
     )
 
   if (nrow(model_info_parsnip_only) == 0) {
-    check_mode_with_no_engine(cls, mode)
+    check_mode_with_no_engine(cls, mode, call = call)
     return(invisible(NULL))
   }
 
@@ -251,7 +252,8 @@ check_spec_mode_engine_val <- function(cls, eng, mode) {
       paste0(
         "Engine '", eng, "' is not supported for `", cls, "()`. See ",
         "`show_engines('", cls, "')`."
-      )
+      ),
+      call = call
     )
   }
 
@@ -265,9 +267,9 @@ check_spec_mode_engine_val <- function(cls, eng, mode) {
   spec_modes <- unique(c("unknown", spec_modes))
 
   if (is.null(mode) || length(mode) > 1) {
-    stop_incompatible_mode(spec_modes, eng)
+    stop_incompatible_mode(spec_modes, eng, call = call)
   } else if (!(mode %in% spec_modes)) {
-    stop_incompatible_mode(spec_modes, eng)
+    stop_incompatible_mode(spec_modes, eng, call = call)
   }
 
   # ----------------------------------------------------------------------------
@@ -279,16 +281,16 @@ check_spec_mode_engine_val <- function(cls, eng, mode) {
   }
   spec_engs <- unique(spec_engs)
   if (!is.null(eng) && !(eng %in% spec_engs)) {
-    stop_incompatible_engine(spec_engs, mode)
+    stop_incompatible_engine(spec_engs, mode, call = call)
   }
 
   invisible(NULL)
 }
 
-check_mode_with_no_engine <- function(cls, mode) {
+check_mode_with_no_engine <- function(cls, mode, call) {
   spec_modes <- get_from_env(paste0(cls, "_modes"))
   if (!(mode %in% spec_modes)) {
-    stop_incompatible_mode(spec_modes, cls = cls)
+    stop_incompatible_mode(spec_modes, cls = cls, call = call)
   }
 }
 

R/arguments.R

@@ -96,7 +96,7 @@ set_mode.model_spec <- function(object, mode) {
   cls <- class(object)[1]
   if (rlang::is_missing(mode)) {
     spec_modes <- rlang::env_get(get_model_env(), paste0(cls, "_modes"))
-    stop_incompatible_mode(spec_modes, cls = cls)
+    stop_incompatible_mode(spec_modes, cls = cls, call = caller_env(0))
   }
 
   # determine if the model specification could feasibly match any entry

R/engines.R

@@ -113,7 +113,7 @@ set_engine.model_spec <- function(object, engine, ...) {
   mod_type <- class(object)[1]
 
   if (rlang::is_missing(engine)) {
-    stop_missing_engine(mod_type)
+    stop_missing_engine(mod_type, call = caller_env(0))
   }
   object$engine <- engine
 

R/misc.R

@@ -311,7 +311,7 @@ new_model_spec <- function(cls, args, eng_args, mode, user_specified_mode = TRUE
   class(out) <- make_classes(cls)
 
   if (!spec_is_possible(spec = out)) {
-    check_spec_mode_engine_val(cls, engine, mode)
+    check_spec_mode_engine_val(cls, engine, mode, call = caller_env())
   }
 
   out

R/translate.R

@@ -153,7 +153,7 @@ deharmonize <- function(args, key) {
 
 add_methods <- function(x, engine) {
   x$engine <- engine
-  check_spec_mode_engine_val(class(x)[1], x$engine, x$mode)
+  check_spec_mode_engine_val(class(x)[1], x$engine, x$mode, call = caller_env())
   x$method <- get_model_spec(specific_model(x), x$mode, x$engine)
   x
 }

tests/testthat/_snaps/args_and_modes.md

@@ -1,3 +1,91 @@
+# can't set a mode that isn't allowed by the model spec
+
+    Code
+      set_mode(linear_reg(), "classification")
+    Condition
+      Error in `set_mode()`:
+      ! 'classification' is not a known mode for model `linear_reg()`.
+
+# unavailable modes for an engine and vice-versa
+
+    Code
+      decision_tree() %>% set_mode("regression") %>% set_engine("C5.0")
+    Condition
+      Error in `set_engine()`:
+      ! Available modes for engine C5.0 are: 'unknown', 'classification'
+
+---
+
+    Code
+      decision_tree(mode = "regression", engine = "C5.0")
+    Condition
+      Error in `decision_tree()`:
+      ! Available modes for engine C5.0 are: 'unknown', 'classification'
+
+---
+
+    Code
+      decision_tree() %>% set_engine("C5.0") %>% set_mode("regression")
+    Condition
+      Error in `set_mode()`:
+      ! Available modes for engine C5.0 are: 'unknown', 'classification'
+
+---
+
+    Code
+      decision_tree(engine = NULL) %>% set_engine("C5.0") %>% set_mode("regression")
+    Condition
+      Error in `set_mode()`:
+      ! Available modes for engine C5.0 are: 'unknown', 'classification'
+
+---
+
+    Code
+      decision_tree(engine = NULL) %>% set_mode("regression") %>% set_engine("C5.0")
+    Condition
+      Error in `set_engine()`:
+      ! Available modes for engine C5.0 are: 'unknown', 'classification'
+
+---
+
+    Code
+      proportional_hazards() %>% set_mode("regression")
+    Condition
+      Error in `set_mode()`:
+      ! 'regression' is not a known mode for model `proportional_hazards()`.
+
+---
+
+    Code
+      linear_reg() %>% set_mode()
+    Condition
+      Error in `set_mode()`:
+      ! Available modes for model type linear_reg are: 'unknown', 'regression'
+
+---
+
+    Code
+      linear_reg(engine = "boop")
+    Condition
+      Error in `linear_reg()`:
+      ! Engine 'boop' is not supported for `linear_reg()`. See `show_engines('linear_reg')`.
+
+---
+
+    Code
+      linear_reg() %>% set_engine()
+    Condition
+      Error in `set_engine()`:
+      ! Missing engine. Possible mode/engine combinations are: regression {lm, glm, glmnet, stan, spark, keras, brulee}
+
+---
+
+    Code
+      proportional_hazards() %>% set_engine()
+    Condition
+      Error in `set_engine()`:
+      ! No known engines for `proportional_hazards()`.
+
 # set_* functions error when input isn't model_spec
 
     Code

tests/testthat/test_args_and_modes.R

@@ -40,64 +40,71 @@ test_that('pipe engine', {
 })
 
 test_that("can't set a mode that isn't allowed by the model spec", {
-  expect_error(
+  expect_snapshot(
     set_mode(linear_reg(), "classification"),
-    "'classification' is not a known mode"
+    error = TRUE
   )
 })
 
 
 
 test_that("unavailable modes for an engine and vice-versa", {
-  expect_error(
+  expect_snapshot(
     decision_tree() %>%
       set_mode("regression") %>%
       set_engine("C5.0"),
-    "Available modes for engine C5"
+    error = TRUE
   )
-  expect_error(
+
+  expect_snapshot(
+    decision_tree(mode = "regression", engine = "C5.0"),
+    error = TRUE
+  )
+
+  expect_snapshot(
     decision_tree() %>%
       set_engine("C5.0") %>%
       set_mode("regression"),
-    "Available modes for engine C5"
+    error = TRUE
   )
 
-  expect_error(
+  expect_snapshot(
     decision_tree(engine = NULL) %>%
       set_engine("C5.0") %>%
       set_mode("regression"),
-    "Available modes for engine C5"
+    error = TRUE
   )
 
-  expect_error(
+  expect_snapshot(
     decision_tree(engine = NULL)%>%
       set_mode("regression") %>%
       set_engine("C5.0"),
-    "Available modes for engine C5"
+    error = TRUE
   )
 
-  expect_error(
-    expect_message(
-      proportional_hazards() %>% set_mode("regression")
-    ),
-    "'regression' is not a known mode"
+  expect_snapshot(
+    proportional_hazards() %>% set_mode("regression"),
+    error = TRUE
   )
 
-  expect_error(
+  expect_snapshot(
     linear_reg() %>% set_mode(),
-    "Available modes for model type linear_reg"
+    error = TRUE
+  )
+
+  expect_snapshot(
+    linear_reg(engine = "boop"),
+    error = TRUE
   )
 
-  expect_error(
+  expect_snapshot(
     linear_reg() %>% set_engine(),
-    "Missing engine"
+    error = TRUE
   )
 
-  expect_error(
-    expect_message(
-      proportional_hazards() %>% set_engine()
-    ),
-    "No known engines for"
+  expect_snapshot(
+    proportional_hazards() %>% set_engine(),
+    error = TRUE
   )
 })