From 1184068c8aac64c1d1598c125e87fa1332430a8b Mon Sep 17 00:00:00 2001 From: Max Kuhn Date: Wed, 23 Oct 2024 16:06:59 -0400 Subject: [PATCH] add rlang type checkers (#950) * add type checking files * remove newly unneeded checking functions * snapshot updates from tidymodels/recipes#1381 * updates files * basic replacements * type checker replacements * tidymodels/tailor#53 * Update R/checks.R Co-authored-by: Simon P. Couch * add remote to get proper error messages * typo * update remotes? * only test snapshots with more recent version of R *with* rankdeficient --------- Co-authored-by: Simon P. Couch --- DESCRIPTION | 15 +- NAMESPACE | 1 + R/0_imports.R | 2 +- R/acquisition.R | 10 +- R/checks.R | 31 +- R/compute_metrics.R | 5 +- R/control.R | 55 ++- R/extract.R | 4 +- R/import-standalone-obj-type.R | 364 ++++++++++++++++++ R/import-standalone-types-check.R | 554 +++++++++++++++++++++++++++ R/logging.R | 12 +- tests/testthat/_snaps/acquisition.md | 28 +- tests/testthat/_snaps/bayes.md | 8 +- tests/testthat/_snaps/checks.md | 121 ++---- tests/testthat/_snaps/collect.md | 52 +++ tests/testthat/_snaps/grid.md | 8 +- tests/testthat/_snaps/notes.md | 48 +-- tests/testthat/_snaps/resample.md | 33 +- tests/testthat/test-checks.R | 14 - tests/testthat/test-collect.R | 4 +- tests/testthat/test-last-fit.R | 3 +- tests/testthat/test-notes.R | 2 +- tests/testthat/test-resample.R | 13 +- 23 files changed, 1144 insertions(+), 243 deletions(-) create mode 100644 R/import-standalone-obj-type.R create mode 100644 R/import-standalone-types-check.R diff --git a/DESCRIPTION b/DESCRIPTION index 8e3028865..f9f0d905e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,7 +4,7 @@ Version: 1.2.1.9000 Authors@R: c( person("Max", "Kuhn", , "max@posit.co", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-2402-136X")), - person(given = "Posit Software, PBC", role = c("cph", "fnd")) + person("Posit Software, PBC", role = c("cph", "fnd")) ) Description: The ability to tune models is important. 'tune' contains functions and classes to be used in conjunction with other @@ -27,12 +27,12 @@ Imports: ggplot2, glue (>= 1.6.2), GPfit, - hardhat (>= 1.2.0), + hardhat (>= 1.4.0.9002), lifecycle (>= 1.0.0), - parsnip (>= 1.2.0), + parsnip (>= 1.2.1.9003), purrr (>= 1.0.0), - recipes (>= 1.0.4), - rlang (>= 1.1.0), + recipes (>= 1.1.0.9001), + rlang (>= 1.1.4), rsample (>= 1.2.1.9000), tailor, tibble (>= 3.1.0), @@ -57,8 +57,11 @@ Suggests: xgboost, xml2 Remotes: + tidymodels/hardhat, + tidymodels/parsnip, + tidymodels/recipes, tidymodels/rsample, - tidymodels/tailor, + tidymodels/tailor, tidymodels/workflows Config/Needs/website: pkgdown, tidymodels, kknn, doParallel, doFuture, tidyverse/tidytemplate diff --git a/NAMESPACE b/NAMESPACE index 2a841975a..2adf3835f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -244,6 +244,7 @@ export(tune_bayes) export(tune_grid) export(val_class_and_single) export(val_class_or_null) +import(rlang) import(vctrs) import(workflows) importFrom(GPfit,GP_fit) diff --git a/R/0_imports.R b/R/0_imports.R index dddebb7a6..de3353c5f 100644 --- a/R/0_imports.R +++ b/R/0_imports.R @@ -22,7 +22,7 @@ #' @importFrom cli cli_inform cli_warn cli_abort qty #' @importFrom foreach foreach getDoParName %dopar% #' @importFrom tibble obj_sum size_sum - +#' @import rlang # ------------------------------------------------------------------------------ # Only a small number of functions in workflows. diff --git a/R/acquisition.R b/R/acquisition.R index 3f5b7230e..540ad9c8d 100644 --- a/R/acquisition.R +++ b/R/acquisition.R @@ -74,8 +74,8 @@ print.prob_improve <- function(x, ...) { #' @export predict.prob_improve <- function(object, new_data, maximize, iter, best, ...) { - check_direction(maximize) - check_best(best) + check_bool(maximize) + check_number_decimal(best, allow_infinite = FALSE) if (is.function(object$trade_off)) { trade_off <- object$trade_off(iter) @@ -126,8 +126,8 @@ exp_improve <- function(trade_off = 0, eps = .Machine$double.eps) { #' @export predict.exp_improve <- function(object, new_data, maximize, iter, best, ...) { - check_direction(maximize) - check_best(best) + check_bool(maximize) + check_number_decimal(best, allow_infinite = FALSE) if (is.function(object$trade_off)) { trade_off <- object$trade_off(iter) @@ -177,7 +177,7 @@ conf_bound <- function(kappa = 0.1) { #' @export predict.conf_bound <- function(object, new_data, maximize, iter, ...) { - check_direction(maximize) + check_bool(maximize) if (is.function(object$kappa)) { kappa <- object$kappa(iter) diff --git a/R/checks.R b/R/checks.R index 4f62e45ad..f2e209a96 100644 --- a/R/checks.R +++ b/R/checks.R @@ -493,26 +493,6 @@ get_objective_name <- function(x, metrics) { x } - -# ------------------------------------------------------------------------------ -# acq functions - -check_direction <- function(x) { - if (!is.logical(x) || length(x) != 1) { - rlang::abort("`maximize` should be a single logical.") - } - invisible(NULL) -} - - -check_best <- function(x) { - if (!is.numeric(x) || length(x) != 1 || is.na(x)) { - rlang::abort("`best` should be a single, non-missing numeric.") - } - invisible(NULL) -} - - # ------------------------------------------------------------------------------ check_class_or_null <- function(x, cls = "numeric") { @@ -537,6 +517,7 @@ val_class_or_null <- function(x, cls = "numeric", where = NULL) { } invisible(NULL) } +# TODO remove this once finetune is updated check_class_and_single <- function(x, cls = "numeric") { isTRUE(inherits(x, cls) & length(x) == 1) @@ -558,7 +539,7 @@ val_class_and_single <- function(x, cls = "numeric", where = NULL) { } invisible(NULL) } - +# TODO remove this once finetune is updated # Check the data going into the GP. If there are all missing values, fail. If some # are missing, remove them and send a warning. If all metrics are the same, fail. @@ -644,3 +625,11 @@ check_eval_time <- function(eval_time, metrics) { invisible(NULL) } + +check_time_limit_arg <- function(x, call = rlang::caller_env()) { + if (!inherits(x, c("logical", "numeric")) || length(x) != 1L) { + cli::cli_abort("{.arg time_limit} should be either a single numeric or + logical value.", call = call) + } + invisible(NULL) +} diff --git a/R/compute_metrics.R b/R/compute_metrics.R index 64d105d3e..94690e905 100644 --- a/R/compute_metrics.R +++ b/R/compute_metrics.R @@ -87,6 +87,7 @@ compute_metrics.tune_results <- function(x, summarize = TRUE, event_level = "first") { rlang::check_dots_empty() + check_bool(summarize) if (!".predictions" %in% names(x)) { rlang::abort(paste0( "`x` must have been generated with the ", @@ -114,10 +115,6 @@ compute_metrics.tune_results <- function(x, )) } - if (!inherits(summarize, "logical") || length(summarize) != 1L) { - rlang::abort("The `summarize` argument must be a single logical value.") - } - param_names <- .get_tune_parameter_names(x) outcome_name <- .get_tune_outcome_names(x) diff --git a/R/control.R b/R/control.R index 26f11ebd6..9dc69d6ce 100644 --- a/R/control.R +++ b/R/control.R @@ -38,15 +38,15 @@ control_grid <- function(verbose = FALSE, allow_par = TRUE, # Any added arguments should also be added in superset control functions # in other packages - # add options for seeds per resample + # add options for seeds per resample + check_bool(verbose) + check_bool(allow_par) + check_bool(save_pred) + check_bool(save_workflow) + check_string(event_level) + check_character(pkgs, allow_null = TRUE) + check_function(extract, allow_null = TRUE) - val_class_and_single(verbose, "logical", "control_grid()") - val_class_and_single(allow_par, "logical", "control_grid()") - val_class_and_single(save_pred, "logical", "control_grid()") - val_class_and_single(save_workflow, "logical", "control_grid()") - val_class_and_single(event_level, "character", "control_grid()") - val_class_or_null(pkgs, "character", "control_grid()") - val_class_or_null(extract, "function", "control_grid()") val_parallel_over(parallel_over, "control_grid()") @@ -241,26 +241,27 @@ control_bayes <- # in other packages # add options for seeds per resample + check_bool(verbose) + check_bool(verbose_iter) + check_bool(allow_par) + check_bool(save_pred) + check_bool(save_workflow) + check_bool(save_gp_scoring) + check_character(pkgs, allow_null = TRUE) + check_function(extract, allow_null = TRUE) + check_number_whole(no_improve, min = 0, allow_infinite = TRUE) + check_number_whole(uncertain, min = 0, allow_infinite = TRUE) + check_number_whole(seed) + + check_time_limit_arg(time_limit) - val_class_and_single(verbose, "logical", "control_bayes()") - val_class_and_single(verbose_iter, "logical", "control_bayes()") - val_class_and_single(save_pred, "logical", "control_bayes()") - val_class_and_single(save_gp_scoring, "logical", "control_bayes()") - val_class_and_single(save_workflow, "logical", "control_bayes()") - val_class_and_single(no_improve, c("numeric", "integer"), "control_bayes()") - val_class_and_single(uncertain, c("numeric", "integer"), "control_bayes()") - val_class_and_single(seed, c("numeric", "integer"), "control_bayes()") - val_class_or_null(extract, "function", "control_bayes()") - val_class_and_single(time_limit, c("logical", "numeric"), "control_bayes()") - val_class_or_null(pkgs, "character", "control_bayes()") - val_class_and_single(event_level, "character", "control_bayes()") val_parallel_over(parallel_over, "control_bayes()") - val_class_and_single(allow_par, "logical", "control_bayes()") if (!is.infinite(uncertain) && uncertain > no_improve) { - cli::cli_alert_warning( - "Uncertainty sample scheduled after {uncertain} poor iterations but the search will stop after {no_improve}." + cli::cli_warn( + "Uncertainty sample scheduled after {uncertain} poor iterations but the + search will stop after {no_improve}." ) } @@ -296,13 +297,11 @@ print.control_bayes <- function(x, ...) { # ------------------------------------------------------------------------------ val_parallel_over <- function(parallel_over, where) { - if (is.null(parallel_over)) { - return(invisible(NULL)) + check_string(parallel_over, allow_null = TRUE) + if (!is.null(parallel_over)) { + rlang::arg_match0(parallel_over, c("resamples", "everything"), "parallel_over") } - val_class_and_single(parallel_over, "character", where) - rlang::arg_match0(parallel_over, c("resamples", "everything"), "parallel_over") - invisible(NULL) } diff --git a/R/extract.R b/R/extract.R index 6bd234f71..0a167f1e3 100644 --- a/R/extract.R +++ b/R/extract.R @@ -109,9 +109,7 @@ extract_spec_parsnip.tune_results <- function(x, ...) { #' @rdname extract-tune extract_recipe.tune_results <- function(x, ..., estimated = TRUE) { check_empty_dots(...) - if (!rlang::is_bool(estimated)) { - rlang::abort("`estimated` must be a single `TRUE` or `FALSE`.") - } + check_bool(estimated) extract_recipe(extract_workflow(x), estimated = estimated) } check_empty_dots <- function(...) { diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 000000000..47268d620 --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -0,0 +1,364 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R +# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-obj-type.R +# last-updated: 2024-02-14 +# license: https://unlicense.org +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 2024-02-14: +# - `obj_type_friendly()` now works for S7 objects. +# +# 2023-05-01: +# - `obj_type_friendly()` now only displays the first class of S3 objects. +# +# 2023-03-30: +# - `stop_input_type()` now handles `I()` input literally in `arg`. +# +# 2022-10-04: +# - `obj_type_friendly(value = TRUE)` now shows numeric scalars +# literally. +# - `stop_friendly_type()` now takes `show_value`, passed to +# `obj_type_friendly()` as the `value` argument. +# +# 2022-10-03: +# - Added `allow_na` and `allow_null` arguments. +# - `NULL` is now backticked. +# - Better friendly type for infinities and `NaN`. +# +# 2022-09-16: +# - Unprefixed usage of rlang functions with `rlang::` to +# avoid onLoad issues when called from rlang (#1482). +# +# 2022-08-11: +# - Prefixed usage of rlang functions with `rlang::`. +# +# 2022-06-22: +# - `friendly_type_of()` is now `obj_type_friendly()`. +# - Added `obj_type_oo()`. +# +# 2021-12-20: +# - Added support for scalar values and empty vectors. +# - Added `stop_input_type()` +# +# 2021-06-30: +# - Added support for missing arguments. +# +# 2021-04-19: +# - Added support for matrices and arrays (#141). +# - Added documentation. +# - Added changelog. +# +# nocov start + +#' Return English-friendly type +#' @param x Any R object. +#' @param value Whether to describe the value of `x`. Special values +#' like `NA` or `""` are always described. +#' @param length Whether to mention the length of vectors and lists. +#' @return A string describing the type. Starts with an indefinite +#' article, e.g. "an integer vector". +#' @noRd +obj_type_friendly <- function(x, value = TRUE) { + if (is_missing(x)) { + return("absent") + } + + if (is.object(x)) { + if (inherits(x, "quosure")) { + type <- "quosure" + } else { + type <- class(x)[[1L]] + } + return(sprintf("a <%s> object", type)) + } + + if (!is_vector(x)) { + return(.rlang_as_friendly_type(typeof(x))) + } + + n_dim <- length(dim(x)) + + if (!n_dim) { + if (!is_list(x) && length(x) == 1) { + if (is_na(x)) { + return(switch( + typeof(x), + logical = "`NA`", + integer = "an integer `NA`", + double = + if (is.nan(x)) { + "`NaN`" + } else { + "a numeric `NA`" + }, + complex = "a complex `NA`", + character = "a character `NA`", + .rlang_stop_unexpected_typeof(x) + )) + } + + show_infinites <- function(x) { + if (x > 0) { + "`Inf`" + } else { + "`-Inf`" + } + } + str_encode <- function(x, width = 30, ...) { + if (nchar(x) > width) { + x <- substr(x, 1, width - 3) + x <- paste0(x, "...") + } + encodeString(x, ...) + } + + if (value) { + if (is.numeric(x) && is.infinite(x)) { + return(show_infinites(x)) + } + + if (is.numeric(x) || is.complex(x)) { + number <- as.character(round(x, 2)) + what <- if (is.complex(x)) "the complex number" else "the number" + return(paste(what, number)) + } + + return(switch( + typeof(x), + logical = if (x) "`TRUE`" else "`FALSE`", + character = { + what <- if (nzchar(x)) "the string" else "the empty string" + paste(what, str_encode(x, quote = "\"")) + }, + raw = paste("the raw value", as.character(x)), + .rlang_stop_unexpected_typeof(x) + )) + } + + return(switch( + typeof(x), + logical = "a logical value", + integer = "an integer", + double = if (is.infinite(x)) show_infinites(x) else "a number", + complex = "a complex number", + character = if (nzchar(x)) "a string" else "\"\"", + raw = "a raw value", + .rlang_stop_unexpected_typeof(x) + )) + } + + if (length(x) == 0) { + return(switch( + typeof(x), + logical = "an empty logical vector", + integer = "an empty integer vector", + double = "an empty numeric vector", + complex = "an empty complex vector", + character = "an empty character vector", + raw = "an empty raw vector", + list = "an empty list", + .rlang_stop_unexpected_typeof(x) + )) + } + } + + vec_type_friendly(x) +} + +vec_type_friendly <- function(x, length = FALSE) { + if (!is_vector(x)) { + abort("`x` must be a vector.") + } + type <- typeof(x) + n_dim <- length(dim(x)) + + add_length <- function(type) { + if (length && !n_dim) { + paste0(type, sprintf(" of length %s", length(x))) + } else { + type + } + } + + if (type == "list") { + if (n_dim < 2) { + return(add_length("a list")) + } else if (is.data.frame(x)) { + return("a data frame") + } else if (n_dim == 2) { + return("a list matrix") + } else { + return("a list array") + } + } + + type <- switch( + type, + logical = "a logical %s", + integer = "an integer %s", + numeric = , + double = "a double %s", + complex = "a complex %s", + character = "a character %s", + raw = "a raw %s", + type = paste0("a ", type, " %s") + ) + + if (n_dim < 2) { + kind <- "vector" + } else if (n_dim == 2) { + kind <- "matrix" + } else { + kind <- "array" + } + out <- sprintf(type, kind) + + if (n_dim >= 2) { + out + } else { + add_length(out) + } +} + +.rlang_as_friendly_type <- function(type) { + switch( + type, + + list = "a list", + + NULL = "`NULL`", + environment = "an environment", + externalptr = "a pointer", + weakref = "a weak reference", + S4 = "an S4 object", + + name = , + symbol = "a symbol", + language = "a call", + pairlist = "a pairlist node", + expression = "an expression vector", + + char = "an internal string", + promise = "an internal promise", + ... = "an internal dots object", + any = "an internal `any` object", + bytecode = "an internal bytecode object", + + primitive = , + builtin = , + special = "a primitive function", + closure = "a function", + + type + ) +} + +.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { + abort( + sprintf("Unexpected type <%s>.", typeof(x)), + call = call + ) +} + +#' Return OO type +#' @param x Any R object. +#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, +#' `"R6"`, or `"S7"`. +#' @noRd +obj_type_oo <- function(x) { + if (!is.object(x)) { + return("bare") + } + + class <- inherits(x, c("R6", "S7_object"), which = TRUE) + + if (class[[1]]) { + "R6" + } else if (class[[2]]) { + "S7" + } else if (isS4(x)) { + "S4" + } else { + "S3" + } +} + +#' @param x The object type which does not conform to `what`. Its +#' `obj_type_friendly()` is taken and mentioned in the error message. +#' @param what The friendly expected type as a string. Can be a +#' character vector of expected types, in which case the error +#' message mentions all of them in an "or" enumeration. +#' @param show_value Passed to `value` argument of `obj_type_friendly()`. +#' @param ... Arguments passed to [abort()]. +#' @inheritParams args_error_context +#' @noRd +stop_input_type <- function(x, + what, + ..., + allow_na = FALSE, + allow_null = FALSE, + show_value = TRUE, + arg = caller_arg(x), + call = caller_env()) { + # From standalone-cli.R + cli <- env_get_list( + nms = c("format_arg", "format_code"), + last = topenv(), + default = function(x) sprintf("`%s`", x), + inherit = TRUE + ) + + if (allow_na) { + what <- c(what, cli$format_code("NA")) + } + if (allow_null) { + what <- c(what, cli$format_code("NULL")) + } + if (length(what)) { + what <- oxford_comma(what) + } + if (inherits(arg, "AsIs")) { + format_arg <- identity + } else { + format_arg <- cli$format_arg + } + + message <- sprintf( + "%s must be %s, not %s.", + format_arg(arg), + what, + obj_type_friendly(x, value = show_value) + ) + + abort(message, ..., call = call, arg = arg) +} + +oxford_comma <- function(chr, sep = ", ", final = "or") { + n <- length(chr) + + if (n < 2) { + return(chr) + } + + head <- chr[seq_len(n - 1)] + last <- chr[n] + + head <- paste(head, collapse = sep) + + # Write a or b. But a, b, or c. + if (n > 2) { + paste0(head, sep, final, " ", last) + } else { + paste0(head, " ", final, " ", last) + } +} + +# nocov end diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R new file mode 100644 index 000000000..ef8c5a1d5 --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,554 @@ +# Standalone file: do not edit by hand +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-types-check.R +# Generated by: usethis::use_standalone("r-lib/rlang", "types-check") +# ---------------------------------------------------------------------- +# +# --- +# repo: r-lib/rlang +# file: standalone-types-check.R +# last-updated: 2023-03-13 +# license: https://unlicense.org +# dependencies: standalone-obj-type.R +# imports: rlang (>= 1.1.0) +# --- +# +# ## Changelog +# +# 2024-08-15: +# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) +# +# 2023-03-13: +# - Improved error messages of number checkers (@teunbrand) +# - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). +# - Added `check_data_frame()` (@mgirlich). +# +# 2023-03-07: +# - Added dependency on rlang (>= 1.1.0). +# +# 2023-02-15: +# - Added `check_logical()`. +# +# - `check_bool()`, `check_number_whole()`, and +# `check_number_decimal()` are now implemented in C. +# +# - For efficiency, `check_number_whole()` and +# `check_number_decimal()` now take a `NULL` default for `min` and +# `max`. This makes it possible to bypass unnecessary type-checking +# and comparisons in the default case of no bounds checks. +# +# 2022-10-07: +# - `check_number_whole()` and `_decimal()` no longer treat +# non-numeric types such as factors or dates as numbers. Numeric +# types are detected with `is.numeric()`. +# +# 2022-10-04: +# - Added `check_name()` that forbids the empty string. +# `check_string()` allows the empty string by default. +# +# 2022-09-28: +# - Removed `what` arguments. +# - Added `allow_na` and `allow_null` arguments. +# - Added `allow_decimal` and `allow_infinite` arguments. +# - Improved errors with absent arguments. +# +# +# 2022-09-16: +# - Unprefixed usage of rlang functions with `rlang::` to +# avoid onLoad issues when called from rlang (#1482). +# +# 2022-08-11: +# - Added changelog. +# +# nocov start + +# Scalars ----------------------------------------------------------------- + +.standalone_types_check_dot_call <- .Call + +check_bool <- function(x, + ..., + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x) && .standalone_types_check_dot_call(ffi_standalone_is_bool_1.0.7, x, allow_na, allow_null)) { + return(invisible(NULL)) + } + + stop_input_type( + x, + c("`TRUE`", "`FALSE`"), + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_string <- function(x, + ..., + allow_empty = TRUE, + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + is_string <- .rlang_check_is_string( + x, + allow_empty = allow_empty, + allow_na = allow_na, + allow_null = allow_null + ) + if (is_string) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a single string", + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +.rlang_check_is_string <- function(x, + allow_empty, + allow_na, + allow_null) { + if (is_string(x)) { + if (allow_empty || !is_string(x, "")) { + return(TRUE) + } + } + + if (allow_null && is_null(x)) { + return(TRUE) + } + + if (allow_na && (identical(x, NA) || identical(x, na_chr))) { + return(TRUE) + } + + FALSE +} + +check_name <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + is_string <- .rlang_check_is_string( + x, + allow_empty = FALSE, + allow_na = FALSE, + allow_null = allow_null + ) + if (is_string) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a valid name", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +IS_NUMBER_true <- 0 +IS_NUMBER_false <- 1 +IS_NUMBER_oob <- 2 + +check_number_decimal <- function(x, + ..., + min = NULL, + max = NULL, + allow_infinite = TRUE, + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if (0 == (exit_code <- .standalone_types_check_dot_call( + ffi_standalone_check_number_1.0.7, + x, + allow_decimal = TRUE, + min, + max, + allow_infinite, + allow_na, + allow_null + ))) { + return(invisible(NULL)) + } + + .stop_not_number( + x, + ..., + exit_code = exit_code, + allow_decimal = TRUE, + min = min, + max = max, + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_number_whole <- function(x, + ..., + min = NULL, + max = NULL, + allow_infinite = FALSE, + allow_na = FALSE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (missing(x)) { + exit_code <- IS_NUMBER_false + } else if (0 == (exit_code <- .standalone_types_check_dot_call( + ffi_standalone_check_number_1.0.7, + x, + allow_decimal = FALSE, + min, + max, + allow_infinite, + allow_na, + allow_null + ))) { + return(invisible(NULL)) + } + + .stop_not_number( + x, + ..., + exit_code = exit_code, + allow_decimal = FALSE, + min = min, + max = max, + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +.stop_not_number <- function(x, + ..., + exit_code, + allow_decimal, + min, + max, + allow_na, + allow_null, + arg, + call) { + if (allow_decimal) { + what <- "a number" + } else { + what <- "a whole number" + } + + if (exit_code == IS_NUMBER_oob) { + min <- min %||% -Inf + max <- max %||% Inf + + if (min > -Inf && max < Inf) { + what <- sprintf("%s between %s and %s", what, min, max) + } else if (x < min) { + what <- sprintf("%s larger than or equal to %s", what, min) + } else if (x > max) { + what <- sprintf("%s smaller than or equal to %s", what, max) + } else { + abort("Unexpected state in OOB check", .internal = TRUE) + } + } + + stop_input_type( + x, + what, + ..., + allow_na = allow_na, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_symbol <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a symbol", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_arg <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_symbol(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an argument name", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_call <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_call(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a defused call", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_environment <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_environment(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an environment", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_function <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_function(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a function", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_closure <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_closure(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "an R function", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_formula <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_formula(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a formula", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + + +# Vectors ----------------------------------------------------------------- + +# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` + +check_character <- function(x, + ..., + allow_na = TRUE, + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + + if (!missing(x)) { + if (is_character(x)) { + if (!allow_na && any(is.na(x))) { + abort( + sprintf("`%s` can't contain NA values.", arg), + arg = arg, + call = call + ) + } + + return(invisible(NULL)) + } + + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a character vector", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_logical <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is_logical(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a logical vector", + ..., + allow_na = FALSE, + allow_null = allow_null, + arg = arg, + call = call + ) +} + +check_data_frame <- function(x, + ..., + allow_null = FALSE, + arg = caller_arg(x), + call = caller_env()) { + if (!missing(x)) { + if (is.data.frame(x)) { + return(invisible(NULL)) + } + if (allow_null && is_null(x)) { + return(invisible(NULL)) + } + } + + stop_input_type( + x, + "a data frame", + ..., + allow_null = allow_null, + arg = arg, + call = call + ) +} + +# nocov end diff --git a/R/logging.R b/R/logging.R index fcf2cbd72..335c66e11 100644 --- a/R/logging.R +++ b/R/logging.R @@ -32,15 +32,9 @@ #' @export message_wrap <- function(x, width = options()$width - 2, prefix = "", color_text = NULL, color_prefix = color_text) { - if (!is.character(x) || length(x) > 1) { - rlang::abort("'x' should be a single character string.") - } - if (!is.null(color_text) && !is.function(color_text)) { - rlang::abort("'color_text' should be null or a function.") - } - if (!is.null(color_prefix) && !is.function(color_prefix)) { - rlang::abort("'color_prefix' should be null or a function.") - } + check_string(x) + check_function(color_text, allow_null = TRUE) + check_function(color_prefix, allow_null = TRUE) n <- nchar(prefix) if (n > 0) { buffer <- paste0(rep(" ", n + 1), collapse = "") diff --git a/tests/testthat/_snaps/acquisition.md b/tests/testthat/_snaps/acquisition.md index b10ee381f..e476ac2fb 100644 --- a/tests/testthat/_snaps/acquisition.md +++ b/tests/testthat/_snaps/acquisition.md @@ -19,8 +19,8 @@ Code predict(conf_bound(), test_res, maximize = 2, iter = 1) Condition - Error in `check_direction()`: - ! `maximize` should be a single logical. + Error in `predict()`: + ! `maximize` must be `TRUE` or `FALSE`, not the number 2. # prob_improve interface @@ -43,24 +43,24 @@ Code predict(prob_improve(), test_res, maximize = 2, iter = 1) Condition - Error in `check_direction()`: - ! `maximize` should be a single logical. + Error in `predict()`: + ! `maximize` must be `TRUE` or `FALSE`, not the number 2. --- Code predict(prob_improve(), test_res, maximize = TRUE, iter = 1, best = NA) Condition - Error in `check_best()`: - ! `best` should be a single, non-missing numeric. + Error in `predict()`: + ! `best` must be a number, not `NA`. --- Code predict(prob_improve(), test_res, maximize = TRUE, iter = 1, best = "WAT") Condition - Error in `check_best()`: - ! `best` should be a single, non-missing numeric. + Error in `predict()`: + ! `best` must be a number, not the string "WAT". # exp_improve interface @@ -83,22 +83,22 @@ Code predict(exp_improve(), test_res, maximize = 2, iter = 1) Condition - Error in `check_direction()`: - ! `maximize` should be a single logical. + Error in `predict()`: + ! `maximize` must be `TRUE` or `FALSE`, not the number 2. --- Code predict(exp_improve(), test_res, maximize = TRUE, iter = 1, best = NA) Condition - Error in `check_best()`: - ! `best` should be a single, non-missing numeric. + Error in `predict()`: + ! `best` must be a number, not `NA`. --- Code predict(exp_improve(), test_res, maximize = TRUE, iter = 1, best = "WAT") Condition - Error in `check_best()`: - ! `best` should be a single, non-missing numeric. + Error in `predict()`: + ! `best` must be a number, not the string "WAT". diff --git a/tests/testthat/_snaps/bayes.md b/tests/testthat/_snaps/bayes.md index e8cd169d8..d2e2f99fd 100644 --- a/tests/testthat/_snaps/bayes.md +++ b/tests/testthat/_snaps/bayes.md @@ -393,12 +393,12 @@ Message x Fold1: preprocessor 1/1: Error in `step_spline_b()`: - Caused by error in `glue()`: - ! Expecting '}' + Caused by error in `spline_msg()`: + ! Error in if (df < 0) : missing value where TRUE/FALSE needed x Fold2: preprocessor 1/1: Error in `step_spline_b()`: - Caused by error in `glue()`: - ! Expecting '}' + Caused by error in `spline_msg()`: + ! Error in if (df < 0) : missing value where TRUE/FALSE needed Condition Warning: All models failed. Run `show_notes(.Last.tune.result)` for more information. diff --git a/tests/testthat/_snaps/checks.md b/tests/testthat/_snaps/checks.md index 8643ac51a..32977008d 100644 --- a/tests/testthat/_snaps/checks.md +++ b/tests/testthat/_snaps/checks.md @@ -92,22 +92,6 @@ Error in `tune:::check_workflow()`: ! A parsnip model is required. -# errors informatively when needed package isn't installed - - Code - check_workflow(stan_wflow) - Condition - Error: - ! Package install is required for rstanarm. - ---- - - Code - fit_resamples(stan_wflow, rsample::bootstraps(mtcars)) - Condition - Error in `fit_resamples()`: - ! Package install is required for rstanarm. - # workflow objects (will not tune, tidymodels/tune#548) Code @@ -163,48 +147,48 @@ Code control_grid(verbose = 1) Condition - Error in `val_class_and_single()`: - ! Argument 'verbose' should be a single logical value in `control_grid()` + Error in `control_grid()`: + ! `verbose` must be `TRUE` or `FALSE`, not the number 1. --- Code control_grid(verbose = rep(TRUE, 2)) Condition - Error in `val_class_and_single()`: - ! Argument 'verbose' should be a single logical value in `control_grid()` + Error in `control_grid()`: + ! `verbose` must be `TRUE` or `FALSE`, not a logical vector. --- Code control_grid(allow_par = 1) Condition - Error in `val_class_and_single()`: - ! Argument 'allow_par' should be a single logical value in `control_grid()` + Error in `control_grid()`: + ! `allow_par` must be `TRUE` or `FALSE`, not the number 1. --- Code control_grid(save_pred = "no") Condition - Error in `val_class_and_single()`: - ! Argument 'save_pred' should be a single logical value in `control_grid()` + Error in `control_grid()`: + ! `save_pred` must be `TRUE` or `FALSE`, not the string "no". --- Code control_grid(extract = Inf) Condition - Error in `val_class_or_null()`: - ! Argument 'extract' should be a function or NULL in `control_grid()` + Error in `control_grid()`: + ! `extract` must be a function or `NULL`, not `Inf`. --- Code control_grid(pkgs = Inf) Condition - Error in `val_class_or_null()`: - ! Argument 'pkgs' should be a character or NULL in `control_grid()` + Error in `control_grid()`: + ! `pkgs` must be a character vector or `NULL`, not `Inf`. # Bayes control objects @@ -219,79 +203,80 @@ Code control_bayes(verbose = 1) Condition - Error in `val_class_and_single()`: - ! Argument 'verbose' should be a single logical value in `control_bayes()` + Error in `control_bayes()`: + ! `verbose` must be `TRUE` or `FALSE`, not the number 1. --- Code control_bayes(verbose = rep(TRUE, 2)) Condition - Error in `val_class_and_single()`: - ! Argument 'verbose' should be a single logical value in `control_bayes()` + Error in `control_bayes()`: + ! `verbose` must be `TRUE` or `FALSE`, not a logical vector. --- Code control_bayes(no_improve = FALSE) Condition - Error in `val_class_and_single()`: - ! Argument 'no_improve' should be a single numeric or integer value in `control_bayes()` + Error in `control_bayes()`: + ! `no_improve` must be a whole number, not `FALSE`. --- Code control_bayes(uncertain = FALSE) Condition - Error in `val_class_and_single()`: - ! Argument 'uncertain' should be a single numeric or integer value in `control_bayes()` + Error in `control_bayes()`: + ! `uncertain` must be a whole number, not `FALSE`. --- Code control_bayes(seed = FALSE) Condition - Error in `val_class_and_single()`: - ! Argument 'seed' should be a single numeric or integer value in `control_bayes()` + Error in `control_bayes()`: + ! `seed` must be a whole number, not `FALSE`. --- Code control_bayes(save_pred = "no") Condition - Error in `val_class_and_single()`: - ! Argument 'save_pred' should be a single logical value in `control_bayes()` + Error in `control_bayes()`: + ! `save_pred` must be `TRUE` or `FALSE`, not the string "no". --- Code control_bayes(extract = Inf) Condition - Error in `val_class_or_null()`: - ! Argument 'extract' should be a function or NULL in `control_bayes()` + Error in `control_bayes()`: + ! `extract` must be a function or `NULL`, not `Inf`. --- Code control_bayes(pkgs = Inf) Condition - Error in `val_class_or_null()`: - ! Argument 'pkgs' should be a character or NULL in `control_bayes()` + Error in `control_bayes()`: + ! `pkgs` must be a character vector or `NULL`, not `Inf`. --- Code control_bayes(time_limit = "a") Condition - Error in `val_class_and_single()`: - ! Argument 'time_limit' should be a single logical or numeric value in `control_bayes()` + Error in `control_bayes()`: + ! `time_limit` should be either a single numeric or logical value. --- Code tmp <- control_bayes(no_improve = 2, uncertain = 5) - Message - ! Uncertainty sample scheduled after 5 poor iterations but the search will stop after 2. + Condition + Warning: + Uncertainty sample scheduled after 5 poor iterations but the search will stop after 2. # initial values @@ -303,46 +288,6 @@ Error in `tune:::check_initial()`: ! `initial` should be a positive integer or the results of [tune_grid()] -# Acquisition function objects - - Code - tune:::check_direction(1) - Condition - Error in `tune:::check_direction()`: - ! `maximize` should be a single logical. - ---- - - Code - tune:::check_direction(rep(TRUE, 2)) - Condition - Error in `tune:::check_direction()`: - ! `maximize` should be a single logical. - ---- - - Code - tune:::check_best(FALSE) - Condition - Error in `tune:::check_best()`: - ! `best` should be a single, non-missing numeric. - ---- - - Code - tune:::check_best(rep(2, 2)) - Condition - Error in `tune:::check_best()`: - ! `best` should be a single, non-missing numeric. - ---- - - Code - tune:::check_best(NA) - Condition - Error in `tune:::check_best()`: - ! `best` should be a single, non-missing numeric. - # check parameter finalization Code diff --git a/tests/testthat/_snaps/collect.md b/tests/testthat/_snaps/collect.md index 67af0b6c2..2976215c2 100644 --- a/tests/testthat/_snaps/collect.md +++ b/tests/testthat/_snaps/collect.md @@ -22,6 +22,58 @@ Error in `filter_predictions()`: ! `parameters` should only have columns: 'cost value' +# collecting notes - fit_resamples + + Code + lm_splines <- fit_resamples(lin_mod, mpg ~ ., flds) + Message + ! Bootstrap1: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Bootstrap2: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + +--- + + Code + lm_splines + Output + # Resampling results + # Bootstrap sampling + # A tibble: 2 x 4 + splits id .metrics .notes + + 1 Bootstrap1 + 2 Bootstrap2 + + There were issues with some computations: + + - Warning(s) x2: prediction from rank-deficient fit; consider predict(., rankdefic... + + Run `show_notes(.Last.tune.result)` for more information. + +# collecting notes - last_fit + + Code + lst <- last_fit(lin_mod, mpg ~ ., split) + Message + ! train/test split: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + +--- + + Code + lst + Output + # Resampling results + # Manual resampling + # A tibble: 1 x 6 + splits id .metrics .notes .predictions .workflow + + 1 train/test split + + There were issues with some computations: + + - Warning(s) x1: prediction from rank-deficient fit; consider predict(., rankdefic... + + Run `show_notes(.Last.tune.result)` for more information. + # `collect_notes()` errors informatively applied to unsupported class Code diff --git a/tests/testthat/_snaps/grid.md b/tests/testthat/_snaps/grid.md index 02190f18b..4f64bce43 100644 --- a/tests/testthat/_snaps/grid.md +++ b/tests/testthat/_snaps/grid.md @@ -8,12 +8,12 @@ Message x Fold1: preprocessor 1/1: Error in `step_spline_b()`: - Caused by error in `glue()`: - ! Expecting '}' + Caused by error in `spline_msg()`: + ! Error in if (df < 0) : missing value where TRUE/FALSE needed x Fold2: preprocessor 1/1: Error in `step_spline_b()`: - Caused by error in `glue()`: - ! Expecting '}' + Caused by error in `spline_msg()`: + ! Error in if (df < 0) : missing value where TRUE/FALSE needed Condition Warning: All models failed. Run `show_notes(.Last.tune.result)` for more information. diff --git a/tests/testthat/_snaps/notes.md b/tests/testthat/_snaps/notes.md index a200ab8be..6eb3e5efd 100644 --- a/tests/testthat/_snaps/notes.md +++ b/tests/testthat/_snaps/notes.md @@ -5,34 +5,34 @@ Message x Fold01: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold02: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold03: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold04: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold05: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold06: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold07: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold08: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold09: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. x Fold10: preprocessor 1/1, model 1/1 (predictions): Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'st... + ! The following required column is missing from `new_data`: date. Condition Warning: All models failed. Run `show_notes(.Last.tune.result)` for more information. @@ -43,25 +43,25 @@ show_notes(res_roles) Output unique notes: - -------------------------------------------------------------------------------- + ----------------------------------------------------------------- Error in `step_date()`: - ! The following required column is missing from `new_data` in step 'step_date': date. + ! The following required column is missing from `new_data`: date. --- Code res_simple <- simple_wflow %>% fit_resamples(rs) Message - ! Fold01: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold02: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold03: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold04: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold05: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold06: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold07: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold08: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold09: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading - ! Fold10: preprocessor 1/1, model 1/1 (predictions): prediction from a rank-deficient fit may be misleading + ! Fold01: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold02: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold03: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold04: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold05: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold06: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold07: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold08: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold09: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") + ! Fold10: preprocessor 1/1, model 1/1 (predictions): prediction from rank-deficient fit; consider predict(., rankdeficient="NA") --- @@ -69,8 +69,8 @@ show_notes(res_simple) Output unique notes: - ------------------------------------------------------ - prediction from a rank-deficient fit may be misleading + --------------------------------------------------------------------------- + prediction from rank-deficient fit; consider predict(., rankdeficient="NA") --- diff --git a/tests/testthat/_snaps/resample.md b/tests/testthat/_snaps/resample.md index a1128a46e..e768f80c2 100644 --- a/tests/testthat/_snaps/resample.md +++ b/tests/testthat/_snaps/resample.md @@ -5,16 +5,23 @@ Message x Fold1: preprocessor 1/1: Error in `step_spline_natural()`: - Caused by error in `glue()`: - ! Expecting '}' + Caused by error in `spline_msg()`: + ! Error in if (df < 2) : missing value where TRUE/FALSE needed x Fold2: preprocessor 1/1: Error in `step_spline_natural()`: - Caused by error in `glue()`: - ! Expecting '}' + Caused by error in `spline_msg()`: + ! Error in if (df < 2) : missing value where TRUE/FALSE needed Condition Warning: All models failed. Run `show_notes(.Last.tune.result)` for more information. +--- + + Code + note + Output + [1] "Error in `step_spline_natural()`:\nCaused by error in `spline_msg()`:\n! Error in if (df < 2) { : missing value where TRUE/FALSE needed" + # failure in variables tidyselect specification is caught elegantly Code @@ -32,6 +39,13 @@ Warning: All models failed. Run `show_notes(.Last.tune.result)` for more information. +--- + + Code + note + Output + [1] "Error in `fit()`:\n! Can't select columns that don't exist.\nx Column `foobar` doesn't exist." + # classification models generate correct error message Code @@ -39,14 +53,21 @@ Message x Fold1: preprocessor 1/1, model 1/1: Error in `check_outcome()`: - ! For a classification model, the outcome should be a `factor`, not a ... + ! For a classification model, the outcome should be a , not a ... x Fold2: preprocessor 1/1, model 1/1: Error in `check_outcome()`: - ! For a classification model, the outcome should be a `factor`, not a ... + ! For a classification model, the outcome should be a , not a ... Condition Warning: All models failed. Run `show_notes(.Last.tune.result)` for more information. +--- + + Code + note + Output + [1] "Error in `check_outcome()`:\n! For a classification model, the outcome should be a , not a double vector." + # `tune_grid()` falls back to `fit_resamples()` - formula Code diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index 573a9787f..abd32d3bc 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -412,20 +412,6 @@ test_that("initial values", { # ------------------------------------------------------------------------------ - -test_that("Acquisition function objects", { - expect_null(tune:::check_direction(FALSE)) - expect_snapshot(error = TRUE, tune:::check_direction(1)) - expect_snapshot(error = TRUE, tune:::check_direction(rep(TRUE, 2))) - - expect_null(tune:::check_best(1)) - expect_snapshot(error = TRUE, tune:::check_best(FALSE)) - expect_snapshot(error = TRUE, tune:::check_best(rep(2, 2))) - expect_snapshot(error = TRUE, tune:::check_best(NA)) -}) - -# ------------------------------------------------------------------------------ - test_that("validation helpers", { expect_true(tune:::check_class_or_null("a", "character")) expect_true(tune:::check_class_or_null(letters, "character")) diff --git a/tests/testthat/test-collect.R b/tests/testthat/test-collect.R index 87830a199..6f42d44f8 100644 --- a/tests/testthat/test-collect.R +++ b/tests/testthat/test-collect.R @@ -182,7 +182,7 @@ test_that("classification class and prob predictions, averaged", { test_that("collecting notes - fit_resamples", { skip_if(new_rng_snapshots) - skip_if(rankdeficient_version) + skip_if(!rankdeficient_version) skip_if_not_installed("modeldata") skip_if_not_installed("splines2") @@ -205,7 +205,7 @@ test_that("collecting notes - fit_resamples", { }) test_that("collecting notes - last_fit", { - skip_if(rankdeficient_version) + skip_if(!rankdeficient_version) options(pillar.advice = FALSE, pillar.min_title_chars = Inf) diff --git a/tests/testthat/test-last-fit.R b/tests/testthat/test-last-fit.R index 68516cf73..d44c9e3d0 100644 --- a/tests/testthat/test-last-fit.R +++ b/tests/testthat/test-last-fit.R @@ -234,6 +234,7 @@ test_that("last_fit() can include validation set for initial_validation_split ob test_that("can use `last_fit()` with a workflow - postprocessor (requires training)", { skip_if_not_installed("tailor") skip_if_not_installed("mgcv") + skip_if_not_installed("tailor", minimum_version = "0.0.0.9002") y <- seq(0, 7, .001) dat <- data.frame(y = y, x = y + (y-3)^2) @@ -277,7 +278,7 @@ test_that("can use `last_fit()` with a workflow - postprocessor (requires traini }) test_that("can use `last_fit()` with a workflow - postprocessor (does not require training)", { - skip_if_not_installed("tailor") + skip_if_not_installed("tailor", minimum_version = "0.0.0.9002") y <- seq(0, 7, .001) dat <- data.frame(y = y, x = y + (y-3)^2) diff --git a/tests/testthat/test-notes.R b/tests/testthat/test-notes.R index da7ced15c..ce475dd17 100644 --- a/tests/testthat/test-notes.R +++ b/tests/testthat/test-notes.R @@ -7,7 +7,7 @@ library(yardstick) test_that("showing notes", { skip_if_not_installed("modeldata") - skip_if(rankdeficient_version) + skip_if(!rankdeficient_version) data(Chicago, package = "modeldata") diff --git a/tests/testthat/test-resample.R b/tests/testthat/test-resample.R index 8ece9953b..ace12d23d 100644 --- a/tests/testthat/test-resample.R +++ b/tests/testthat/test-resample.R @@ -140,7 +140,7 @@ test_that("extracted workflow is finalized", { }) test_that("can use `fit_resamples()` with a workflow - postprocessor (requires training)", { - skip_if_not_installed("tailor") + skip_if_not_installed("tailor", minimum_version = "0.0.0.9002") y <- seq(0, 7, .001) dat <- data.frame(y = y, x = y + (y-3)^2) @@ -202,7 +202,7 @@ test_that("can use `fit_resamples()` with a workflow - postprocessor (requires t }) test_that("can use `fit_resamples()` with a workflow - postprocessor (no training)", { - skip_if_not_installed("tailor") + skip_if_not_installed("tailor", minimum_version = "0.0.0.9002") y <- seq(0, 7, .001) dat <- data.frame(y = y, x = y + (y-3)^2) @@ -277,8 +277,7 @@ test_that("failure in recipe is caught elegantly", { expect_length(notes, 2L) - # Known failure in the recipe - expect_true(any(grepl("Expecting", note))) + expect_snapshot(note) expect_equal(extract, list(NULL, NULL)) expect_equal(predictions, list(NULL, NULL)) @@ -309,8 +308,7 @@ test_that("failure in variables tidyselect specification is caught elegantly", { expect_length(notes, 2L) - # Known failure in the variables part - expect_true(any(grepl("foobar", note))) + expect_snapshot(note) expect_equal(extract, list(NULL, NULL)) expect_equal(predictions, list(NULL, NULL)) @@ -339,8 +337,7 @@ test_that("classification models generate correct error message", { expect_length(notes, 2L) - # Known failure in the recipe - expect_true(all(grepl("outcome should be a `factor`", note))) + expect_snapshot(note) expect_equal(extract, list(NULL, NULL)) expect_equal(predictions, list(NULL, NULL))