diff --git a/R/convert_data.R b/R/convert_data.R index 73fea702d..4bae393dd 100644 --- a/R/convert_data.R +++ b/R/convert_data.R @@ -384,7 +384,7 @@ check_dup_names <- function(x, y, call = rlang::caller_env()) { #' @return A data frame, matrix, or sparse matrix. #' @export maybe_matrix <- function(x) { - inher(x, c("data.frame", "matrix", "dgCMatrix"), cl = match.call()) + check_inherits(x, c("data.frame", "matrix", "dgCMatrix")) if (is.data.frame(x)) { non_num_cols <- vapply(x, function(x) !is.numeric(x), logical(1)) if (any(non_num_cols)) { diff --git a/R/fit.R b/R/fit.R index ff6fb71ff..3f9c7a8ee 100644 --- a/R/fit.R +++ b/R/fit.R @@ -55,11 +55,11 @@ #' a "reverse Kaplan-Meier" curve that models the probability of censoring. This #' may be used later to compute inverse probability censoring weights for #' performance measures. -#' +#' #' Sparse data is supported, with the use of the `x` argument in `fit_xy()`. See -#' `allow_sparse_x` column of [parsnip::get_encoding()] for sparse input +#' `allow_sparse_x` column of [parsnip::get_encoding()] for sparse input #' compatibility. -#' +#' #' @examplesIf !parsnip:::is_cran_check() #' # Although `glm()` only has a formula interface, different #' # methods for specifying the model can be used @@ -121,21 +121,17 @@ fit.model_spec <- control <- condense_control(control, control_parsnip()) check_case_weights(case_weights, object) - if (!inherits(formula, "formula")) { - msg <- "The {.arg formula} argument must be a formula, but it is a \\ - {.cls {class(formula)[1]}}." - - if (inherits(formula, "recipe")) { - msg <- - c( - msg, - "i" = "To fit a model with a recipe preprocessor, please use a \\ + if (inherits(formula, "recipe")) { + cli::cli_abort( + c( + "The {.arg formula} argument must be a formula.", + "i" = "To fit a model with a recipe preprocessor, please use a \\ {.help [workflow](workflows::workflow)}." - ) - } - - cli::cli_abort(msg) + ) + ) } + check_formula(formula) + if (is_sparse_matrix(data)) { data <- sparsevctrs::coerce_to_sparse_tibble(data) @@ -179,7 +175,7 @@ fit.model_spec <- eval_env$weights <- wts data <- materialize_sparse_tibble(data, object, "data") - + fit_interface <- check_interface(eval_env$formula, eval_env$data, cl, object) @@ -297,10 +293,11 @@ fit_xy.model_spec <- # TODO case weights: pass in eval_env not individual elements fit_interface <- check_xy_interface(eval_env$x, eval_env$y, cl, object) - if (object$engine == "spark") + if (object$engine == "spark") { cli::cli_abort( - "spark objects can only be used with the formula interface to {.fn fit} with a spark data object." + "spark objects can only be used with the formula interface to {.fn fit} with a spark data object." ) + } # populate `method` with the details for this model type object <- add_methods(object, engine = object$engine) @@ -373,59 +370,47 @@ eval_mod <- function(e, capture = FALSE, catch = FALSE, envir = NULL, ...) { # ------------------------------------------------------------------------------ -inher <- function(x, cls, cl) { - if (!is.null(x) && !inherits(x, cls)) { - - call <- match.call() - obj <- deparse(call[["x"]]) - - if (length(cls) > 1) - cli::cli_abort( - "{.arg {obj}} should be one of the following classes: {.cls {cls}}.") - - else - cli::cli_abort("{.arg {obj}} should be a {.cls {cls}} object") - } - invisible(x) -} - -# ------------------------------------------------------------------------------ - -check_interface <- function(formula, data, cl, model) { - inher(formula, "formula", cl) - inher(data, c("data.frame", "dgCMatrix", "tbl_spark"), cl) +check_interface <- function(formula, data, cl, model, call = caller_env()) { + check_formula(formula, call = call) + check_inherits(data, c("data.frame", "dgCMatrix", "tbl_spark"), call = call) # Determine the `fit()` interface form_interface <- !is.null(formula) & !is.null(data) if (form_interface) return("formula") - cli::cli_abort("Error when checking the interface.") + cli::cli_abort("Error when checking the interface.", call = call) } -check_xy_interface <- function(x, y, cl, model) { +check_xy_interface <- function(x, y, cl, model, call = caller_env()) { sparse_ok <- allow_sparse(model) sparse_x <- inherits(x, "dgCMatrix") if (!sparse_ok & sparse_x) { - cli::cli_abort("Sparse matrices not supported by this model/engine combination.") + cli::cli_abort( + "Sparse matrices not supported by this model/engine combination.", + call = call + ) } if (sparse_ok) { - inher(x, c("data.frame", "matrix", "dgCMatrix"), cl) + check_inherits(x, c("data.frame", "matrix", "dgCMatrix"), call = call) } else { - inher(x, c("data.frame", "matrix"), cl) + check_inherits(x, c("data.frame", "matrix"), call = call) } - if (!is.null(y) && !is.atomic(y)) - inher(y, c("data.frame", "matrix"), cl) + if (!is.null(y) && !is.atomic(y)) { + check_inherits(y, c("data.frame", "matrix"), call = call) + } # rule out spark data sets that don't use the formula interface - if (inherits(x, "tbl_spark") | inherits(y, "tbl_spark")) + if (inherits(x, "tbl_spark") | inherits(y, "tbl_spark")) { cli::cli_abort( - "spark objects can only be used with the formula interface via {.fn fit} with a spark data object." - ) - + "spark objects can only be used with the formula interface via + {.fn fit} with a spark data object.", + call = call + ) + } if (sparse_ok) { matrix_interface <- !is.null(x) && !is.null(y) && (is.matrix(x) | sparse_x) @@ -444,7 +429,7 @@ check_xy_interface <- function(x, y, cl, model) { check_outcome(y, model) - cli::cli_abort("Error when checking the interface") + cli::cli_abort("Error when checking the interface.", call = call) } allow_sparse <- function(x) { diff --git a/R/misc.R b/R/misc.R index ee41f22c2..0afbe6602 100644 --- a/R/misc.R +++ b/R/misc.R @@ -533,6 +533,21 @@ check_case_weights <- function(x, spec, call = rlang::caller_env()) { invisible(NULL) } +# ------------------------------------------------------------------------------ + +check_inherits <- function(x, cls, arg = caller_arg(x), call = caller_env()) { + if (is.null(x)) { + return(invisible(x)) + } + + if (!inherits(x, cls)) { + cli::cli_abort( + "{.arg {arg}} should be a {.cls {cls}}, not {.obj_type_friendly {x}}.", + call = call + ) + } +} + # ----------------------------------------------------------------------------- check_for_newdata <- function(..., call = rlang::caller_env()) { if (any(names(list(...)) == "newdata")) { diff --git a/tests/testthat/_snaps/fit_interfaces.md b/tests/testthat/_snaps/fit_interfaces.md index d9281ac2e..deb41d5f4 100644 --- a/tests/testthat/_snaps/fit_interfaces.md +++ b/tests/testthat/_snaps/fit_interfaces.md @@ -4,7 +4,7 @@ fit(linear_reg(), rec, mtcars) Condition Error in `fit()`: - ! The `formula` argument must be a formula, but it is a . + ! The `formula` argument must be a formula. i To fit a model with a recipe preprocessor, please use a workflow (`?workflows::workflow()`). --- @@ -13,7 +13,7 @@ fit(linear_reg(), "boop", mtcars) Condition Error in `fit()`: - ! The `formula` argument must be a formula, but it is a . + ! `formula` must be a formula, not the string "boop". # No loaded engines