Add condense_control() function

NAMESPACE

@@ -155,6 +155,7 @@ export(check_empty_ellipse)
 export(check_final_param)
 export(check_model_doesnt_exist)
 export(check_model_exists)
+export(condense_control)
 export(contr_one_hot)
 export(control_parsnip)
 export(convert_stan_interval)

NEWS.md

@@ -4,6 +4,8 @@
 
 * `fit_xy()` now fails when the model mode is unknown. 
 
+* `fit()` and `fit_xy()` doesn't error anymore if `control` argument isn't a `control_parsnip()` object. Will work as long as the object passed to `control` includes the same elements as `control_parsnip()`.
+
 # parsnip 1.0.1
 
 * Enabled passing additional engine arguments with the xgboost `boost_tree()` engine. To supply engine-specific arguments that are documented in `xgboost::xgb.train()` as arguments to be passed via `params`, supply the list elements directly as named arguments to `set_engine()`. Read more in `?details_boost_tree_xgboost` (#787).

R/condense_control.R

@@ -0,0 +1,43 @@
+#' Condense control object into strictly smaller control object
+#'
+#' This function is used to help the hierarchy of control functions used
+#' throughout the tidymodels packages. It is now assumed that each control
+#' function is either a subset or a superset of another control function.
+#'
+#' @param x A control object to be condensed.
+#' @param ref A control object that is used to determine what element should be
+#'   kept.
+#'
+#' @return A control object with the same elements and classes of `ref`, with
+#'   values of `x`.
+#' @keywords internal
+#' @export
+#'
+#' @examples
+#' ctrl <- control_parsnip(catch = TRUE)
+#' ctrl$allow_par <- TRUE
+#' str(ctrl)
+#'
+#' ctrl <- condense_control(ctrl, control_parsnip())
+#' str(ctrl)
+condense_control <- function(x, ref) {
+  mismatch <- setdiff(names(ref), names(x))
+  if (length(mismatch)) {
+    rlang::abort(
+      c(
+        glue::glue(
+          "Object of class `{class(x)[1]}` cannot be corresed to ",
+          "object of class `{class(ref)[1]}`."
+        ),
+        "The following arguments are missing:",
+        glue::glue_collapse(
+          glue::single_quote(mismatch),
+          sep = ", ", last = ", and "
+        )
+      )
+    )
+  }
+  res <- x[names(ref)]
+  class(res) <- class(ref)
+  res
+}

R/control_parsnip.R

@@ -20,6 +20,8 @@
 #'
 #' @export
 control_parsnip <- function(verbosity = 1L, catch = FALSE) {
+  # Any added arguments should also be added in superset control functions
+  # in other packages
   res <- list(verbosity = verbosity, catch = catch)
   res <- check_control(res)
   class(res) <- "control_parsnip"

R/fit.R

@@ -112,9 +112,7 @@ fit.model_spec <-
     if (object$mode == "unknown") {
       rlang::abort("Please set the mode in the model specification.")
     }
-    if (!identical(class(control), class(control_parsnip()))) {
-      rlang::abort("The 'control' argument should have class 'control_parsnip'.")
-    }
+    control <- condense_control(control, control_parsnip())
     check_case_weights(case_weights, object)
 
     dots <- quos(...)
@@ -238,9 +236,8 @@ fit_xy.model_spec <-
       rlang::abort("Survival models must use the formula interface.")
     }
 
-    if (!identical(class(control), class(control_parsnip()))) {
-      rlang::abort("The 'control' argument should have class 'control_parsnip'.")
-    }
+    control <- condense_control(control, control_parsnip())
+
     if (is.null(colnames(x))) {
       rlang::abort("'x' should have column names.")
     }

_pkgdown.yml

@@ -94,6 +94,7 @@ reference:
 
   - title: Developer tools
     contents:
+      - condense_control
       - contr_one_hot
       - set_new_model
       - maybe_matrix

tests/testthat/_snaps/condense_control.md

@@ -0,0 +1,10 @@
+# condense_control works
+
+    Code
+      condense_control(control_parsnip(), ctrl)
+    Condition
+      Error in `condense_control()`:
+      ! Object of class `control_parsnip` cannot be corresed to object of class `control_parsnip`.
+      * The following arguments are missing:
+      * 'allow_par', and 'anotherone'
+

tests/testthat/test_condense_control.R

@@ -0,0 +1,21 @@
+test_that("condense_control works", {
+  ctrl <- control_parsnip()
+
+  expect_equal(
+    condense_control(ctrl, ctrl),
+    ctrl
+  )
+
+  ctrl$allow_par <- TRUE
+  ctrl$catch <- TRUE
+
+  expect_equal(
+    condense_control(ctrl, control_parsnip()),
+    control_parsnip(catch = TRUE)
+  )
+
+  ctrl$anotherone <- 2
+  expect_snapshot(error = TRUE,
+    condense_control(control_parsnip(), ctrl)
+  )
+})

tests/testthat/test_misc.R

@@ -76,13 +76,15 @@ test_that('control class', {
   x <- linear_reg() %>% set_engine("lm")
   ctrl <- control_parsnip()
   class(ctrl) <- c("potato", "chair")
+  # This doesn't error anymore because `condense_control()` doesn't care about
+  # classes, it cares about elements
   expect_error(
     fit(x, mpg ~ ., data = mtcars, control = ctrl),
-    "The 'control' argument should have class 'control_parsnip'"
+    NA
   )
   expect_error(
     fit_xy(x, x = mtcars[, -1], y = mtcars$mpg, control = ctrl),
-    "The 'control' argument should have class 'control_parsnip'"
+    NA
   )
 })