From cebc6723270a1e01caf4047852d054cc572f4bfd Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 14:39:06 -0700 Subject: [PATCH 1/3] repo: fix imports and remove unused standalone files --- DESCRIPTION | 1 + NAMESPACE | 12 - R/epipredict-package.R | 10 +- R/import-standalone-lifecycle.R | 254 -------------- R/import-standalone-obj-type.R | 363 -------------------- R/import-standalone-types-check.R | 553 ------------------------------ R/pivot_quantiles.R | 2 +- man/autoplot-epipred.Rd | 2 - 8 files changed, 7 insertions(+), 1190 deletions(-) delete mode 100644 R/import-standalone-lifecycle.R delete mode 100644 R/import-standalone-obj-type.R delete mode 100644 R/import-standalone-types-check.R diff --git a/DESCRIPTION b/DESCRIPTION index 26093014c..c76280d45 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,6 +35,7 @@ Imports: ggplot2, glue, hardhat (>= 1.3.0), + lifecycle, magrittr, recipes (>= 1.0.4), rlang (>= 1.1.0), diff --git a/NAMESPACE b/NAMESPACE index ea516dbde..e815203eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -273,24 +273,12 @@ importFrom(rlang,caller_arg) importFrom(rlang,caller_env) importFrom(rlang,enquo) importFrom(rlang,enquos) -importFrom(rlang,env_get_list) importFrom(rlang,expr) importFrom(rlang,global_env) importFrom(rlang,inject) -importFrom(rlang,is_call) -importFrom(rlang,is_character) -importFrom(rlang,is_closure) -importFrom(rlang,is_environment) -importFrom(rlang,is_formula) -importFrom(rlang,is_function) -importFrom(rlang,is_list) importFrom(rlang,is_logical) -importFrom(rlang,is_missing) importFrom(rlang,is_null) -importFrom(rlang,is_string) -importFrom(rlang,is_symbol) importFrom(rlang,is_true) -importFrom(rlang,is_vector) importFrom(rlang,set_names) importFrom(rlang,sym) importFrom(stats,as.formula) diff --git a/R/epipredict-package.R b/R/epipredict-package.R index adde4967d..ad0f95295 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,13 +1,13 @@ ## usethis namespace: start #' @import epiprocess parsnip -#' @importFrom checkmate assert assert_character assert_int assert_scalar -#' @importFrom checkmate assert_logical assert_numeric assert_number -#' @importFrom checkmate assert_integer assert_integerish -#' @importFrom checkmate assert_date assert_function assert_class +#' @importFrom checkmate assert_class assert_numeric +#' @importFrom checkmate test_character test_date test_function +#' @importFrom checkmate test_integerish test_logical +#' @importFrom checkmate test_numeric test_scalar #' @importFrom cli cli_abort cli_warn #' @importFrom dplyr arrange across all_of any_of bind_cols bind_rows group_by -#' @importFrom dplyr summarize filter mutate select left_join rename ungroup #' @importFrom dplyr full_join relocate summarise everything +#' @importFrom dplyr summarize filter mutate select left_join rename ungroup #' @importFrom rlang := !! %||% as_function global_env set_names !!! caller_arg #' @importFrom rlang is_logical is_true inject enquo enquos expr sym arg_match #' @importFrom stats poly predict lm residuals quantile diff --git a/R/import-standalone-lifecycle.R b/R/import-standalone-lifecycle.R deleted file mode 100644 index a1be17134..000000000 --- a/R/import-standalone-lifecycle.R +++ /dev/null @@ -1,254 +0,0 @@ -# Standalone file: do not edit by hand -# Source: -# ---------------------------------------------------------------------- -# -# --- -# repo: r-lib/rlang -# file: standalone-lifecycle.R -# last-updated: 2023-02-23 -# license: https://unlicense.org -# imports: rlang (>= 1.0.0) -# --- -# -# This file serves as a reference for currently unexported rlang -# lifecycle functions. These functions require rlang in your `Imports` -# DESCRIPTION field but you don't need to import rlang in your -# namespace. -# -# ## Changelog -# -# 2023-02-23 -# -# - Updated the API and internals to match modern lifecycle tools. -# -# -# 2021-04-19 -# -# - Removed `lifecycle()` function. You can now use the following in -# your roxygen documentation to inline a badge: -# -# ``` -# `r lifecycle::badge()` -# ``` -# -# This is a build-time dependency on lifecycle so there is no need -# to add lifecycle to Imports just to use badges. See also -# `?usethis::use_lifecycle()` for importing or updating the badge -# images in your package. -# -# - Soft-namespaced private objects. -# -# nocov start - - -#' Signal deprecation -#' -#' @description -#' These functions provide two levels of verbosity for deprecation -#' warnings. -#' -#' * `deprecate_soft()` warns only if called directly: from the global -#' environment (so the user can change their script) or from the -#' package currently being tested (so the package developer can fix -#' the package). -#' -#' * `deprecate_warn()` warns unconditionally. -#' -#' * `deprecate_stop()` fails unconditionally. -#' -#' Both functions warn only once per session by default to avoid -#' overwhelming the user with repeated warnings. -#' -#' @param msg The deprecation message. -#' @param id The id of the deprecation. A warning is issued only once -#' for each `id`. Defaults to `msg`, but you should give a unique ID -#' when the message is built programmatically and depends on inputs. -#' @param user_env The environment in which the deprecated function -#' was called. The verbosity depends on whether the deprecated -#' feature was called directly, see [rlang::env_is_user_facing()] and the -#' documentation in the lifecycle package. -#' -#' @section Controlling verbosity: -#' -#' The verbosity of retirement warnings can be controlled with global -#' options. You'll generally want to set these options locally with -#' one of these helpers: -#' -#' * `with_lifecycle_silence()` disables all soft-deprecation and -#' deprecation warnings. -#' -#' * `with_lifecycle_warnings()` enforces warnings for both -#' soft-deprecated and deprecated functions. The warnings are -#' repeated rather than signalled once per session. -#' -#' * `with_lifecycle_errors()` enforces errors for both -#' soft-deprecated and deprecated functions. -#' -#' All the `with_` helpers have `scoped_` variants that are -#' particularly useful in testthat blocks. -#' -#' @noRd -NULL - -deprecate_soft <- function(msg, - id = msg, - user_env = rlang::caller_env(2)) { - .rlang_lifecycle_signal_stage(msg, "deprecated") - - id <- paste(id, collapse = "\n") - verbosity <- .rlang_lifecycle_verbosity() - - invisible(switch( - verbosity, - quiet = NULL, - warning = , - default = - if (rlang::env_is_user_facing(user_env)) { - always <- verbosity == "warning" - trace <- rlang::trace_back(bottom = caller_env()) - .rlang_lifecycle_deprecate_warn0( - msg, - id = id, - trace = trace, - always = always - ) - }, - error = deprecate_stop(msg) - )) -} - -deprecate_warn <- function(msg, - id = msg, - always = FALSE, - user_env = rlang::caller_env(2)) { - .rlang_lifecycle_signal_stage(msg, "deprecated") - - id <- paste(id, collapse = "\n") - verbosity <- .rlang_lifecycle_verbosity() - - invisible(switch( - verbosity, - quiet = NULL, - warning = , - default = { - direct <- rlang::env_is_user_facing(user_env) - always <- direct && (always || verbosity == "warning") - - trace <- tryCatch( - rlang::trace_back(bottom = rlang::caller_env()), - error = function(...) NULL - ) - - .rlang_lifecycle_deprecate_warn0( - msg, - id = id, - trace = trace, - always = always - ) - }, - error = deprecate_stop(msg), - )) -} - -.rlang_lifecycle_deprecate_warn0 <- function(msg, - id = msg, - trace = NULL, - always = FALSE, - call = rlang::caller_env()) { - if (always) { - freq <- "always" - } else { - freq <- "regularly" - } - - rlang::warn( - msg, - class = "lifecycle_warning_deprecated", - .frequency = freq, - .frequency_id = id - ) -} - -deprecate_stop <- function(msg) { - msg <- cli::format_error(msg) - .rlang_lifecycle_signal_stage(msg, "deprecated") - - stop(rlang::cnd( - c("defunctError", "error", "condition"), - old = NULL, - new = NULL, - package = NULL, - message = msg - )) -} - -.rlang_lifecycle_signal_stage <- function(msg, stage) { - rlang::signal(msg, "lifecycle_stage", stage = stage) -} - -expect_deprecated <- function(expr, regexp = NULL, ...) { - rlang::local_options(lifecycle_verbosity = "warning") - - if (!is.null(regexp) && rlang::is_na(regexp)) { - rlang::abort("`regexp` can't be `NA`.") - } - - testthat::expect_warning( - {{ expr }}, - regexp = regexp, - class = "lifecycle_warning_deprecated", - ... - ) -} - -local_lifecycle_silence <- function(frame = rlang::caller_env()) { - rlang::local_options( - .frame = frame, - lifecycle_verbosity = "quiet" - ) -} -with_lifecycle_silence <- function(expr) { - local_lifecycle_silence() - expr -} - -local_lifecycle_warnings <- function(frame = rlang::caller_env()) { - rlang::local_options( - .frame = frame, - lifecycle_verbosity = "warning" - ) -} -with_lifecycle_warnings <- function(expr) { - local_lifecycle_warnings() - expr -} - -local_lifecycle_errors <- function(frame = rlang::caller_env()) { - rlang::local_options( - .frame = frame, - lifecycle_verbosity = "error" - ) -} -with_lifecycle_errors <- function(expr) { - local_lifecycle_errors() - expr -} - -.rlang_lifecycle_verbosity <- function() { - opt <- getOption("lifecycle_verbosity", "default") - - if (!rlang::is_string(opt, c("quiet", "default", "warning", "error"))) { - options(lifecycle_verbosity = "default") - rlang::warn(glue::glue( - " - The `lifecycle_verbosity` option must be set to one of: - \"quiet\", \"default\", \"warning\", or \"error\". - Resetting to \"default\". - " - )) - } - - opt -} - -# nocov end diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R deleted file mode 100644 index 646aa33fc..000000000 --- a/R/import-standalone-obj-type.R +++ /dev/null @@ -1,363 +0,0 @@ -# Standalone file: do not edit by hand -# Source: -# ---------------------------------------------------------------------- -# -# --- -# 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 deleted file mode 100644 index 1ca83997d..000000000 --- a/R/import-standalone-types-check.R +++ /dev/null @@ -1,553 +0,0 @@ -# Standalone file: do not edit by hand -# Source: -# ---------------------------------------------------------------------- -# -# --- -# 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/pivot_quantiles.R b/R/pivot_quantiles.R index c8601b4f6..f014961e6 100644 --- a/R/pivot_quantiles.R +++ b/R/pivot_quantiles.R @@ -148,7 +148,7 @@ pivot_quantiles <- function(.data, ...) { "{.fn pivot_quantiles} was deprecated in {.pkg epipredict} 0.0.6", i = "Please use {.fn pivot_quantiles_wider} instead." ) - deprecate_stop(msg) + lifecycle::deprecate_stop(msg) } validate_pivot_quantiles <- function(.data, ...) { diff --git a/man/autoplot-epipred.Rd b/man/autoplot-epipred.Rd index 10236eb98..27bfdf5f7 100644 --- a/man/autoplot-epipred.Rd +++ b/man/autoplot-epipred.Rd @@ -121,6 +121,4 @@ arx <- arx_forecaster(jhu, "death_rate", c("case_rate", "death_rate"), args_list = arx_args_list(ahead = 14L) ) autoplot(arx, .max_facets = 6) -NULL - } From f588f0a28f9bcac1612bd7fc3e7016e5fd28ec71 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 13:37:51 -0700 Subject: [PATCH 2/3] tests: snapshot tests on errors --- NAMESPACE | 12 -- R/epipredict-package.R | 8 +- man/autoplot-epipred.Rd | 2 - tests/testthat/_snaps/arx_args_list.md | 152 ++++++++++++++++++ tests/testthat/_snaps/arx_cargs_list.md | 92 +++++++++++ tests/testthat/_snaps/bake-method.md | 9 ++ tests/testthat/_snaps/check-training-set.md | 20 +++ .../_snaps/check_enough_train_data.md | 46 ++++++ tests/testthat/_snaps/dist_quantiles.md | 56 +++++++ tests/testthat/_snaps/enframer.md | 32 ++++ tests/testthat/_snaps/epi_recipe.md | 8 + tests/testthat/_snaps/epi_workflow.md | 17 ++ tests/testthat/_snaps/extract_argument.md | 72 +++++++++ tests/testthat/_snaps/flatline_args_list.md | 128 +++++++++++++++ tests/testthat/_snaps/frosting.md | 16 ++ tests/testthat/_snaps/get_test_data.md | 66 ++++++++ .../_snaps/layer_add_forecast_date.md | 42 +++++ .../testthat/_snaps/layer_add_target_date.md | 8 + tests/testthat/_snaps/layer_predict.md | 8 + .../_snaps/layer_residual_quantiles.md | 18 +++ tests/testthat/_snaps/layers.md | 24 +++ tests/testthat/_snaps/parse_period.md | 32 ++++ .../_snaps/parsnip_model_validation.md | 18 +++ tests/testthat/_snaps/pivot_quantiles.md | 51 ++++++ tests/testthat/_snaps/population_scaling.md | 16 ++ tests/testthat/_snaps/shuffle.md | 8 + tests/testthat/_snaps/step_epi_slide.md | 16 ++ tests/testthat/_snaps/wis-dist-quantiles.md | 17 ++ tests/testthat/test-arx_args_list.R | 36 ++--- tests/testthat/test-arx_cargs_list.R | 22 +-- tests/testthat/test-bake-method.R | 2 +- tests/testthat/test-check-training-set.R | 4 +- tests/testthat/test-check_enough_train_data.R | 21 +-- tests/testthat/test-dist_quantiles.R | 14 +- tests/testthat/test-enframer.R | 8 +- tests/testthat/test-epi_recipe.R | 2 +- tests/testthat/test-epi_workflow.R | 4 +- tests/testthat/test-extract_argument.R | 18 +-- tests/testthat/test-flatline_args_list.R | 30 ++-- tests/testthat/test-frosting.R | 4 +- tests/testthat/test-get_test_data.R | 16 +- tests/testthat/test-layer_add_forecast_date.R | 10 +- tests/testthat/test-layer_add_target_date.R | 2 +- tests/testthat/test-layer_predict.R | 2 +- .../testthat/test-layer_residual_quantiles.R | 8 +- tests/testthat/test-layers.R | 6 +- tests/testthat/test-parse_period.R | 8 +- .../testthat/test-parsnip_model_validation.R | 4 +- tests/testthat/test-pivot_quantiles.R | 12 +- tests/testthat/test-population_scaling.R | 5 +- tests/testthat/test-shuffle.R | 2 +- tests/testthat/test-step_epi_slide.R | 2 + tests/testthat/test-wis-dist-quantiles.R | 4 +- 53 files changed, 1102 insertions(+), 138 deletions(-) create mode 100644 tests/testthat/_snaps/arx_args_list.md create mode 100644 tests/testthat/_snaps/arx_cargs_list.md create mode 100644 tests/testthat/_snaps/bake-method.md create mode 100644 tests/testthat/_snaps/check-training-set.md create mode 100644 tests/testthat/_snaps/check_enough_train_data.md create mode 100644 tests/testthat/_snaps/dist_quantiles.md create mode 100644 tests/testthat/_snaps/enframer.md create mode 100644 tests/testthat/_snaps/extract_argument.md create mode 100644 tests/testthat/_snaps/flatline_args_list.md create mode 100644 tests/testthat/_snaps/frosting.md create mode 100644 tests/testthat/_snaps/get_test_data.md create mode 100644 tests/testthat/_snaps/layer_add_forecast_date.md create mode 100644 tests/testthat/_snaps/layer_add_target_date.md create mode 100644 tests/testthat/_snaps/layer_predict.md create mode 100644 tests/testthat/_snaps/layer_residual_quantiles.md create mode 100644 tests/testthat/_snaps/layers.md create mode 100644 tests/testthat/_snaps/parse_period.md create mode 100644 tests/testthat/_snaps/parsnip_model_validation.md create mode 100644 tests/testthat/_snaps/pivot_quantiles.md create mode 100644 tests/testthat/_snaps/population_scaling.md create mode 100644 tests/testthat/_snaps/shuffle.md create mode 100644 tests/testthat/_snaps/wis-dist-quantiles.md diff --git a/NAMESPACE b/NAMESPACE index ea516dbde..e815203eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -273,24 +273,12 @@ importFrom(rlang,caller_arg) importFrom(rlang,caller_env) importFrom(rlang,enquo) importFrom(rlang,enquos) -importFrom(rlang,env_get_list) importFrom(rlang,expr) importFrom(rlang,global_env) importFrom(rlang,inject) -importFrom(rlang,is_call) -importFrom(rlang,is_character) -importFrom(rlang,is_closure) -importFrom(rlang,is_environment) -importFrom(rlang,is_formula) -importFrom(rlang,is_function) -importFrom(rlang,is_list) importFrom(rlang,is_logical) -importFrom(rlang,is_missing) importFrom(rlang,is_null) -importFrom(rlang,is_string) -importFrom(rlang,is_symbol) importFrom(rlang,is_true) -importFrom(rlang,is_vector) importFrom(rlang,set_names) importFrom(rlang,sym) importFrom(stats,as.formula) diff --git a/R/epipredict-package.R b/R/epipredict-package.R index adde4967d..b6550c6b4 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,9 +1,9 @@ ## usethis namespace: start #' @import epiprocess parsnip -#' @importFrom checkmate assert assert_character assert_int assert_scalar -#' @importFrom checkmate assert_logical assert_numeric assert_number -#' @importFrom checkmate assert_integer assert_integerish -#' @importFrom checkmate assert_date assert_function assert_class +#' @importFrom checkmate assert_class assert_numeric +#' @importFrom checkmate test_character test_date test_function +#' @importFrom checkmate test_integerish test_logical +#' @importFrom checkmate test_numeric test_scalar #' @importFrom cli cli_abort cli_warn #' @importFrom dplyr arrange across all_of any_of bind_cols bind_rows group_by #' @importFrom dplyr summarize filter mutate select left_join rename ungroup diff --git a/man/autoplot-epipred.Rd b/man/autoplot-epipred.Rd index 10236eb98..27bfdf5f7 100644 --- a/man/autoplot-epipred.Rd +++ b/man/autoplot-epipred.Rd @@ -121,6 +121,4 @@ arx <- arx_forecaster(jhu, "death_rate", c("case_rate", "death_rate"), args_list = arx_args_list(ahead = 14L) ) autoplot(arx, .max_facets = 6) -NULL - } diff --git a/tests/testthat/_snaps/arx_args_list.md b/tests/testthat/_snaps/arx_args_list.md new file mode 100644 index 000000000..959a5e25b --- /dev/null +++ b/tests/testthat/_snaps/arx_args_list.md @@ -0,0 +1,152 @@ +# arx_args checks inputs + + Code + arx_args_list(ahead = c(0, 4)) + Condition + Error in `arx_args_list()`: + ! `ahead` must be a scalar. + +--- + + Code + arx_args_list(n_training = c(28, 65)) + Condition + Error in `arx_args_list()`: + ! `n_training` must be a scalar. + +--- + + Code + arx_args_list(ahead = -1) + Condition + Error in `arx_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_args_list(ahead = 1.5) + Condition + Error in `arx_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_args_list(n_training = -1) + Condition + Error in `arx_args_list()`: + ! `n_training` must be a strictly positive number. + +--- + + Code + arx_args_list(n_training = 1.5) + Condition + Error in `arx_args_list()`: + ! `n_training` must be a positive integer. + +--- + + Code + arx_args_list(lags = c(-1, 0)) + Condition + Error in `arx_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_args_list(lags = list(c(1:5, 6.5), 2:8)) + Condition + Error in `arx_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_args_list(symmetrize = 4) + Condition + Error in `arx_args_list()`: + ! `symmetrize` must be of type . + +--- + + Code + arx_args_list(nonneg = 4) + Condition + Error in `arx_args_list()`: + ! `nonneg` must be of type . + +--- + + Code + arx_args_list(quantile_levels = -0.1) + Condition + Error in `arx_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + arx_args_list(quantile_levels = 1.1) + Condition + Error in `arx_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + arx_args_list(target_date = "2022-01-01") + Condition + Error in `arx_args_list()`: + ! `target_date` must be a date. + +--- + + Code + arx_args_list(n_training_min = "de") + Condition + Error in `arx_args_list()`: + ! `...` must be empty. + x Problematic argument: + * n_training_min = "de" + +--- + + Code + arx_args_list(epi_keys = 1) + Condition + Error in `arx_args_list()`: + ! `...` must be empty. + x Problematic argument: + * epi_keys = 1 + +# arx forecaster disambiguates quantiles + + Code + compare_quantile_args(alist, tlist) + Condition + Error in `compare_quantile_args()`: + ! You have specified different, non-default, quantiles in the trainier and `arx_args` options. + i Please only specify quantiles in one location. + +# arx_lags_validator handles named & unnamed lists as expected + + Code + arx_lags_validator(pred_vec, lags_finit_fn_switch2) + Condition + Error in `arx_lags_validator()`: + ! You have requested 2 predictor(s) but 3 different lags. + i Lags must be a vector or a list with length == number of predictors. + +--- + + Code + arx_lags_validator(pred_vec, lags_init_other_name) + Condition + Error in `arx_lags_validator()`: + ! If lags is a named list, then all predictors must be present. + i The predictors are `death_rate` and `case_rate`. + i So lags is missing `case_rate`'. + diff --git a/tests/testthat/_snaps/arx_cargs_list.md b/tests/testthat/_snaps/arx_cargs_list.md new file mode 100644 index 000000000..30ccb4d36 --- /dev/null +++ b/tests/testthat/_snaps/arx_cargs_list.md @@ -0,0 +1,92 @@ +# arx_class_args checks inputs + + Code + arx_class_args_list(ahead = c(0, 4)) + Condition + Error in `arx_class_args_list()`: + ! `ahead` must be a scalar. + +--- + + Code + arx_class_args_list(n_training = c(28, 65)) + Condition + Error in `arx_class_args_list()`: + ! `n_training` must be a scalar. + +--- + + Code + arx_class_args_list(ahead = -1) + Condition + Error in `arx_class_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_class_args_list(ahead = 1.5) + Condition + Error in `arx_class_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_class_args_list(n_training = -1) + Condition + Error in `arx_class_args_list()`: + ! `n_training` must be a strictly positive number. + +--- + + Code + arx_class_args_list(n_training = 1.5) + Condition + Error in `arx_class_args_list()`: + ! `n_training` must be a positive integer. + +--- + + Code + arx_class_args_list(lags = c(-1, 0)) + Condition + Error in `arx_class_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_class_args_list(lags = list(c(1:5, 6.5), 2:8)) + Condition + Error in `arx_class_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_class_args_list(target_date = "2022-01-01") + Condition + Error in `arx_class_args_list()`: + ! `target_date` must be a date. + +--- + + Code + arx_class_args_list(n_training_min = "de") + Condition + Error in `arx_class_args_list()`: + ! `...` must be empty. + x Problematic argument: + * n_training_min = "de" + +--- + + Code + arx_class_args_list(epi_keys = 1) + Condition + Error in `arx_class_args_list()`: + ! `...` must be empty. + x Problematic argument: + * epi_keys = 1 + diff --git a/tests/testthat/_snaps/bake-method.md b/tests/testthat/_snaps/bake-method.md new file mode 100644 index 000000000..eee28cc4b --- /dev/null +++ b/tests/testthat/_snaps/bake-method.md @@ -0,0 +1,9 @@ +# bake method works in all cases + + Code + bake(prep(r, edf), NULL, composition = "matrix") + Condition + Error in `hardhat::recompose()`: + ! `data` must only contain numeric columns. + i These columns aren't numeric: "geo_value" and "time_value". + diff --git a/tests/testthat/_snaps/check-training-set.md b/tests/testthat/_snaps/check-training-set.md new file mode 100644 index 000000000..e5eec7e7c --- /dev/null +++ b/tests/testthat/_snaps/check-training-set.md @@ -0,0 +1,20 @@ +# training set validation works + + Code + validate_meta_match(t1, template, "geo_type", "abort") + Condition + Error in `validate_meta_match()`: + ! The `geo_type` of the training data appears to be different from that + used to construct the recipe. This may result in unexpected consequences. + i Training `geo_type` is 'county'. + i Originally, it was 'state'. + +--- + + Code + epi_check_training_set(t4, rec) + Condition + Error in `epi_check_training_set()`: + ! The recipe specifies keys which are not in the training data. + i The training set is missing columns for missing_col. + diff --git a/tests/testthat/_snaps/check_enough_train_data.md b/tests/testthat/_snaps/check_enough_train_data.md new file mode 100644 index 000000000..8f2389acb --- /dev/null +++ b/tests/testthat/_snaps/check_enough_train_data.md @@ -0,0 +1,46 @@ +# check_enough_train_data works on pooled data + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, + drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +--- + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, + drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +# check_enough_train_data works on unpooled data + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", + drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +--- + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, + epi_keys = "geo_value", drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +# check_enough_train_data works with all_predictors() downstream of constructed terms + + Code + epi_recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% + check_enough_train_data(all_predictors(), y, n = 2 * n - 5) %>% prep( + toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: lag_1_x, lag_2_x, and y. + diff --git a/tests/testthat/_snaps/dist_quantiles.md b/tests/testthat/_snaps/dist_quantiles.md new file mode 100644 index 000000000..da7e50100 --- /dev/null +++ b/tests/testthat/_snaps/dist_quantiles.md @@ -0,0 +1,56 @@ +# constructor returns reasonable quantiles + + Code + new_quantiles(rnorm(5), rnorm(5)) + Condition + Error in `new_quantiles()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + new_quantiles(sort(rnorm(5)), sort(runif(2))) + Condition + Error in `new_quantiles()`: + ! length(values) == length(quantile_levels) is not TRUE + +--- + + Code + new_quantiles(c(2, 1, 3, 4, 5), c(0.1, 0.1, 0.2, 0.5, 0.8)) + Condition + Error in `new_quantiles()`: + ! !vctrs::vec_duplicate_any(quantile_levels) is not TRUE + +--- + + Code + new_quantiles(c(2, 1, 3, 4, 5), c(0.1, 0.15, 0.2, 0.5, 0.8)) + Condition + Error in `new_quantiles()`: + ! `values[order(quantile_levels)]` produces unsorted quantiles. + +--- + + Code + new_quantiles(c(1, 2, 3), c(0.1, 0.2, 3)) + Condition + Error in `new_quantiles()`: + ! `quantile_levels` must lie in [0, 1]. + +# arithmetic works on quantiles + + Code + sum(dstn) + Condition + Error in `mapply()`: + ! You can't perform arithmetic between two distributions like this. + +--- + + Code + suppressWarnings(dstn + distributional::dist_normal()) + Condition + Error: + ! non-numeric argument to binary operator + diff --git a/tests/testthat/_snaps/enframer.md b/tests/testthat/_snaps/enframer.md new file mode 100644 index 000000000..4b05dbff3 --- /dev/null +++ b/tests/testthat/_snaps/enframer.md @@ -0,0 +1,32 @@ +# enframer errors/works as needed + + Code + enframer(1:5, letters[1]) + Condition + Error in `enframer()`: + ! is.data.frame(df) is not TRUE + +--- + + Code + enframer(data.frame(a = 1:5), 1:3) + Condition + Error in `enframer()`: + ! `x` must be of type . + +--- + + Code + enframer(data.frame(a = 1:5), letters[1:3]) + Condition + Error in `enframer()`: + ! In enframer: some new cols match existing column names + +--- + + Code + enframer(data.frame(aa = 1:5), letters[1:2], fill = 1:4) + Condition + Error in `enframer()`: + ! length(fill) == 1 || length(fill) == nrow(df) is not TRUE + diff --git a/tests/testthat/_snaps/epi_recipe.md b/tests/testthat/_snaps/epi_recipe.md index 3d797461d..24b046678 100644 --- a/tests/testthat/_snaps/epi_recipe.md +++ b/tests/testthat/_snaps/epi_recipe.md @@ -22,3 +22,11 @@ Error in `epi_recipe()`: ! `x` must be an or a , not a . +# add/update/adjust/remove epi_recipe works as intended + + Code + workflows::extract_preprocessor(wf)$steps + Condition + Error in `workflows::extract_preprocessor()`: + ! The workflow does not have a preprocessor. + diff --git a/tests/testthat/_snaps/epi_workflow.md b/tests/testthat/_snaps/epi_workflow.md index d46dad6c1..006333423 100644 --- a/tests/testthat/_snaps/epi_workflow.md +++ b/tests/testthat/_snaps/epi_workflow.md @@ -1,3 +1,20 @@ +# model can be added/updated/removed from epi_workflow + + Code + extract_spec_parsnip(wf) + Condition + Error in `extract_spec_parsnip()`: + ! The workflow does not have a model spec. + +# forecast method errors when workflow not fit + + Code + forecast(wf) + Condition + Error in `forecast()`: + ! You cannot `forecast()` a that has not been trained. + i Please use `fit()` before forecasting. + # fit method does not silently drop the class Code diff --git a/tests/testthat/_snaps/extract_argument.md b/tests/testthat/_snaps/extract_argument.md new file mode 100644 index 000000000..d4ff44c95 --- /dev/null +++ b/tests/testthat/_snaps/extract_argument.md @@ -0,0 +1,72 @@ +# layer argument extractor works + + Code + extract_argument(f$layers[[1]], "uhoh", "bubble") + Condition + Error in `extract_argument()`: + ! Requested "uhoh" not found. This is a(n) . + +--- + + Code + extract_argument(f$layers[[1]], "layer_predict", "bubble") + Condition + Error in `extract_argument()`: + ! Requested argument "bubble" not found in "layer_predict". + +--- + + Code + extract_argument(f, "layer_thresh", "quantile_levels") + Condition + Error in `extract_argument()`: + ! frosting object does not contain a "layer_thresh". + +--- + + Code + extract_argument(epi_workflow(), "layer_residual_quantiles", "quantile_levels") + Condition + Error in `extract_frosting()`: + ! The epi_workflow does not have a postprocessor. + +--- + + Code + extract_argument(wf, "layer_predict", c("type", "opts")) + Condition + Error in `FUN()`: + ! `arg` must be a scalar of type . + +# recipe argument extractor works + + Code + extract_argument(r$steps[[1]], "uhoh", "bubble") + Condition + Error in `extract_argument()`: + ! Requested "uhoh" not found. This is a . + +--- + + Code + extract_argument(r$steps[[1]], "step_epi_lag", "bubble") + Condition + Error in `extract_argument()`: + ! Requested argument "bubble" not found in "step_epi_lag". + +--- + + Code + extract_argument(r, "step_lightly", "quantile_levels") + Condition + Error in `extract_argument()`: + ! recipe object does not contain a "step_lightly". + +--- + + Code + extract_argument(epi_workflow(), "step_epi_lag", "lag") + Condition + Error in `extract_argument()`: + ! The workflow must have a recipe preprocessor. + diff --git a/tests/testthat/_snaps/flatline_args_list.md b/tests/testthat/_snaps/flatline_args_list.md new file mode 100644 index 000000000..02053f95b --- /dev/null +++ b/tests/testthat/_snaps/flatline_args_list.md @@ -0,0 +1,128 @@ +# flatline_args_list checks inputs + + Code + flatline_args_list(ahead = c(0, 4)) + Condition + Error in `flatline_args_list()`: + ! `ahead` must be a scalar. + +--- + + Code + flatline_args_list(n_training = c(28, 65)) + Condition + Error in `flatline_args_list()`: + ! `n_training` must be a scalar. + +--- + + Code + flatline_args_list(ahead = -1) + Condition + Error in `flatline_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + flatline_args_list(ahead = 1.5) + Condition + Error in `flatline_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + flatline_args_list(n_training = -1) + Condition + Error in `flatline_args_list()`: + ! `n_training` must be a strictly positive number. + +--- + + Code + flatline_args_list(n_training = 1.5) + Condition + Error in `flatline_args_list()`: + ! `n_training` must be a positive integer. + +--- + + Code + flatline_args_list(lags = c(-1, 0)) + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * lags = c(-1, 0) + +--- + + Code + flatline_args_list(lags = list(c(1:5, 6.5), 2:8)) + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * lags = list(c(1:5, 6.5), 2:8) + +--- + + Code + flatline_args_list(symmetrize = 4) + Condition + Error in `flatline_args_list()`: + ! `symmetrize` must be of type . + +--- + + Code + flatline_args_list(nonneg = 4) + Condition + Error in `flatline_args_list()`: + ! `nonneg` must be of type . + +--- + + Code + flatline_args_list(quantile_levels = -0.1) + Condition + Error in `flatline_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + flatline_args_list(quantile_levels = 1.1) + Condition + Error in `flatline_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + flatline_args_list(target_date = "2022-01-01") + Condition + Error in `flatline_args_list()`: + ! `target_date` must be a date. + +--- + + Code + flatline_args_list(n_training_min = "de") + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * n_training_min = "de" + +--- + + Code + flatline_args_list(epi_keys = 1) + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * epi_keys = 1 + diff --git a/tests/testthat/_snaps/frosting.md b/tests/testthat/_snaps/frosting.md new file mode 100644 index 000000000..daf7f1ed7 --- /dev/null +++ b/tests/testthat/_snaps/frosting.md @@ -0,0 +1,16 @@ +# frosting validators / constructors work + + Code + wf %>% add_postprocessor(list()) + Condition + Error: + ! `postprocessor` must be a frosting object. + +# frosting can be created/added/updated/adjusted/removed + + Code + frosting(layers = 1:5) + Condition + Error in `frosting()`: + ! Currently, no arguments to `frosting()` are allowed to be non-null. + diff --git a/tests/testthat/_snaps/get_test_data.md b/tests/testthat/_snaps/get_test_data.md new file mode 100644 index 000000000..e65b0715c --- /dev/null +++ b/tests/testthat/_snaps/get_test_data.md @@ -0,0 +1,66 @@ +# expect insufficient training data error + + Code + get_test_data(recipe = r, x = case_death_rate_subset) + Condition + Error in `get_test_data()`: + ! You supplied insufficient recent data for this recipe. + ! You need at least 367 days of data, + ! but `x` contains only 365. + +# expect error that geo_value or time_value does not exist + + Code + get_test_data(recipe = r, x = wrong_epi_df) + Condition + Error in `get_test_data()`: + ! `x` must be an `epi_df`. + +# NA fill behaves as desired + + Code + get_test_data(r, df, "A") + Condition + Error in `get_test_data()`: + ! `fill_locf` must be of type . + +--- + + Code + get_test_data(r, df, TRUE, -3) + Condition + Error in `get_test_data()`: + ! `n_recent` must be a positive integer. + +--- + + Code + get_test_data(r, df2, TRUE) + Condition + Error in `if (recipes::is_trained(recipe)) ...`: + ! argument is of length zero + +# forecast date behaves + + Code + get_test_data(r, df, TRUE, forecast_date = 9) + Condition + Error in `get_test_data()`: + ! `forecast_date` must be the same class as `x$time_value`. + +--- + + Code + get_test_data(r, df, TRUE, forecast_date = 9L) + Condition + Error in `get_test_data()`: + ! `forecast_date` must be no earlier than `max(x$time_value)` + +--- + + Code + get_test_data(r, df, forecast_date = 9L) + Condition + Error in `get_test_data()`: + ! `forecast_date` must be no earlier than `max(x$time_value)` + diff --git a/tests/testthat/_snaps/layer_add_forecast_date.md b/tests/testthat/_snaps/layer_add_forecast_date.md new file mode 100644 index 000000000..9e829be91 --- /dev/null +++ b/tests/testthat/_snaps/layer_add_forecast_date.md @@ -0,0 +1,42 @@ +# layer validation works + + Code + layer_add_forecast_date(f, c("2022-05-31", "2022-05-31")) + Condition + Error in `layer_add_forecast_date()`: + ! `forecast_date` must be a scalar. + +--- + + Code + layer_add_forecast_date(f, "2022-05-31", id = 2) + Condition + Error in `layer_add_forecast_date()`: + ! `id` must be a scalar of type . + +--- + + Code + layer_add_forecast_date(f, "2022-05-31", id = c("a", "b")) + Condition + Error in `layer_add_forecast_date()`: + ! `id` must be a scalar of type . + +# forecast date works for daily + + Code + predict(wf1, latest_yearly) + Condition + Error: + ! Can't convert `data$time_value` to match type of `time_value` . + +--- + + Code + predict(wf3, latest) + Condition + Error in `layer_add_forecast_date()`: + ! The `forecast_date` was given as a "year" while the + ! `time_type` of the training data was "day". + i See `?epiprocess::epi_df` for descriptions of these are determined. + diff --git a/tests/testthat/_snaps/layer_add_target_date.md b/tests/testthat/_snaps/layer_add_target_date.md new file mode 100644 index 000000000..805a4205d --- /dev/null +++ b/tests/testthat/_snaps/layer_add_target_date.md @@ -0,0 +1,8 @@ +# target date works for daily and yearly + + Code + predict(wf1, latest_bad) + Condition + Error: + ! Can't convert `data$time_value` to match type of `time_value` . + diff --git a/tests/testthat/_snaps/layer_predict.md b/tests/testthat/_snaps/layer_predict.md new file mode 100644 index 000000000..5c353eb4c --- /dev/null +++ b/tests/testthat/_snaps/layer_predict.md @@ -0,0 +1,8 @@ +# layer_predict dots validation + + Code + predict(wf_bad_arg, latest) + Condition + Error: + ! argument "..3" is missing, with no default + diff --git a/tests/testthat/_snaps/layer_residual_quantiles.md b/tests/testthat/_snaps/layer_residual_quantiles.md new file mode 100644 index 000000000..41aa0448d --- /dev/null +++ b/tests/testthat/_snaps/layer_residual_quantiles.md @@ -0,0 +1,18 @@ +# Errors when used with a classifier + + Code + forecast(wf) + Condition + Error in `grab_residuals()`: + ! For meaningful residuals, the predictor should be a regression model. + +# flatline_forecaster correctly errors when n_training < ahead + + Code + flatline_forecaster(jhu, "death_rate", args_list = flatline_args_list(ahead = 10, + n_training = 9)) + Condition + Error in `slather()`: + ! Residual quantiles could not be calculated due to missing residuals. + i This may be due to `n_train` < `ahead` in your . + diff --git a/tests/testthat/_snaps/layers.md b/tests/testthat/_snaps/layers.md new file mode 100644 index 000000000..a0474eab6 --- /dev/null +++ b/tests/testthat/_snaps/layers.md @@ -0,0 +1,24 @@ +# A layer can be updated in frosting + + Code + update(f$layers[[1]], lower = 100) + Condition + Error in `recipes:::update_fields()`: + ! The step you are trying to update, `layer_predict()`, does not have the lower field. + +--- + + Code + update(f$layers[[3]], lower = 100) + Condition + Error in `f$layers[[3]]`: + ! subscript out of bounds + +--- + + Code + update(f$layers[[2]], bad_param = 100) + Condition + Error in `recipes:::update_fields()`: + ! The step you are trying to update, `layer_threshold()`, does not have the bad_param field. + diff --git a/tests/testthat/_snaps/parse_period.md b/tests/testthat/_snaps/parse_period.md new file mode 100644 index 000000000..bc782dea7 --- /dev/null +++ b/tests/testthat/_snaps/parse_period.md @@ -0,0 +1,32 @@ +# parse_period works + + Code + parse_period(c(1, 2)) + Condition + Error in `parse_period()`: + ! `x` must be a scalar. + +--- + + Code + parse_period(c(1.3)) + Condition + Error in `parse_period()`: + ! rlang::is_integerish(x) is not TRUE + +--- + + Code + parse_period("1 year") + Condition + Error in `parse_period()`: + ! incompatible timespan in `aheads`. + +--- + + Code + parse_period("2 weeks later") + Condition + Error in `parse_period()`: + ! incompatible timespan in `aheads`. + diff --git a/tests/testthat/_snaps/parsnip_model_validation.md b/tests/testthat/_snaps/parsnip_model_validation.md new file mode 100644 index 000000000..365e6b2b8 --- /dev/null +++ b/tests/testthat/_snaps/parsnip_model_validation.md @@ -0,0 +1,18 @@ +# forecaster can validate parsnip model + + Code + get_parsnip_mode(l) + Condition + Error in `get_parsnip_mode()`: + ! `trainer` must be a `parsnip` model. + i This trainer has class: . + +--- + + Code + is_classification(l) + Condition + Error in `get_parsnip_mode()`: + ! `trainer` must be a `parsnip` model. + i This trainer has class: . + diff --git a/tests/testthat/_snaps/pivot_quantiles.md b/tests/testthat/_snaps/pivot_quantiles.md new file mode 100644 index 000000000..184eb62a6 --- /dev/null +++ b/tests/testthat/_snaps/pivot_quantiles.md @@ -0,0 +1,51 @@ +# quantile pivotting wider behaves + + Code + pivot_quantiles_wider(tib, a) + Condition + Error in `UseMethod()`: + ! no applicable method for 'family' applied to an object of class "c('integer', 'numeric')" + +--- + + Code + pivot_quantiles_wider(tib, c) + Condition + Error in `validate_pivot_quantiles()`: + ! Variables(s) `c` are not `dist_quantiles`. Cannot pivot them. + +--- + + Code + pivot_quantiles_wider(tib, d1) + Condition + Error in `pivot_quantiles_wider()`: + ! Quantiles must be the same length and have the same set of taus. + i Check failed for variables(s) `d1`. + +# quantile pivotting longer behaves + + Code + pivot_quantiles_longer(tib, a) + Condition + Error in `UseMethod()`: + ! no applicable method for 'family' applied to an object of class "c('integer', 'numeric')" + +--- + + Code + pivot_quantiles_longer(tib, c) + Condition + Error in `validate_pivot_quantiles()`: + ! Variables(s) `c` are not `dist_quantiles`. Cannot pivot them. + +--- + + Code + pivot_quantiles_longer(tib, d1, d3) + Condition + Error in `pivot_quantiles_longer()`: + ! Some selected columns contain different numbers of quantiles. + The result would be a very long . + To do this anyway, rerun with `.ignore_length_check = TRUE`. + diff --git a/tests/testthat/_snaps/population_scaling.md b/tests/testthat/_snaps/population_scaling.md new file mode 100644 index 000000000..9263e8e1e --- /dev/null +++ b/tests/testthat/_snaps/population_scaling.md @@ -0,0 +1,16 @@ +# expect error if `by` selector does not match + + Code + wf <- epi_workflow(r, parsnip::linear_reg()) %>% fit(jhu) %>% add_frosting(f) + Condition + Error in `hardhat::validate_column_names()`: + ! The following required columns are missing: 'a'. + +--- + + Code + forecast(wf) + Condition + Error in `hardhat::validate_column_names()`: + ! The following required columns are missing: 'nothere'. + diff --git a/tests/testthat/_snaps/shuffle.md b/tests/testthat/_snaps/shuffle.md new file mode 100644 index 000000000..53eea9b92 --- /dev/null +++ b/tests/testthat/_snaps/shuffle.md @@ -0,0 +1,8 @@ +# shuffle works + + Code + shuffle(matrix(NA, 2, 2)) + Condition + Error in `shuffle()`: + ! is.vector(x) is not TRUE + diff --git a/tests/testthat/_snaps/step_epi_slide.md b/tests/testthat/_snaps/step_epi_slide.md index 27ca908b7..a4b9d64c8 100644 --- a/tests/testthat/_snaps/step_epi_slide.md +++ b/tests/testthat/_snaps/step_epi_slide.md @@ -118,6 +118,22 @@ Error in `validate_slide_fun()`: ! In, `step_epi_slide()`, `.f` must be a function. +--- + + Code + r %>% step_epi_slide(value) + Condition + Error in `step_epi_slide()`: + ! argument ".f" is missing, with no default + +--- + + Code + r %>% step_epi_slide(value, .f = 1) + Condition + Error in `validate_slide_fun()`: + ! In, `step_epi_slide()`, `.f` must be a function. + # epi_slide handles different function specs Code diff --git a/tests/testthat/_snaps/wis-dist-quantiles.md b/tests/testthat/_snaps/wis-dist-quantiles.md new file mode 100644 index 000000000..fb9cfbdf6 --- /dev/null +++ b/tests/testthat/_snaps/wis-dist-quantiles.md @@ -0,0 +1,17 @@ +# wis dispatches and produces the correct values + + Code + weighted_interval_score(1:10, 10) + Condition + Error in `weighted_interval_score()`: + ! Weighted interval score can only be calculated if `x` + has class . + +--- + + Code + weighted_interval_score(dist_quantiles(list(1:4, 8:11), 1:4 / 5), 1:3) + Condition + Error in `weighted_interval_score()`: + ! Can't recycle `x` (size 2) to match `actual` (size 3). + diff --git a/tests/testthat/test-arx_args_list.R b/tests/testthat/test-arx_args_list.R index 9d81be024..03cbc0025 100644 --- a/tests/testthat/test-arx_args_list.R +++ b/tests/testthat/test-arx_args_list.R @@ -1,30 +1,30 @@ test_that("arx_args checks inputs", { expect_s3_class(arx_args_list(), c("arx_fcast", "alist")) - expect_error(arx_args_list(ahead = c(0, 4))) - expect_error(arx_args_list(n_training = c(28, 65))) + expect_snapshot(error = TRUE, arx_args_list(ahead = c(0, 4))) + expect_snapshot(error = TRUE, arx_args_list(n_training = c(28, 65))) - expect_error(arx_args_list(ahead = -1)) - expect_error(arx_args_list(ahead = 1.5)) - expect_error(arx_args_list(n_training = -1)) - expect_error(arx_args_list(n_training = 1.5)) - expect_error(arx_args_list(lags = c(-1, 0))) - expect_error(arx_args_list(lags = list(c(1:5, 6.5), 2:8))) + expect_snapshot(error = TRUE, arx_args_list(ahead = -1)) + expect_snapshot(error = TRUE, arx_args_list(ahead = 1.5)) + expect_snapshot(error = TRUE, arx_args_list(n_training = -1)) + expect_snapshot(error = TRUE, arx_args_list(n_training = 1.5)) + expect_snapshot(error = TRUE, arx_args_list(lags = c(-1, 0))) + expect_snapshot(error = TRUE, arx_args_list(lags = list(c(1:5, 6.5), 2:8))) - expect_error(arx_args_list(symmetrize = 4)) - expect_error(arx_args_list(nonneg = 4)) + expect_snapshot(error = TRUE, arx_args_list(symmetrize = 4)) + expect_snapshot(error = TRUE, arx_args_list(nonneg = 4)) - expect_error(arx_args_list(quantile_levels = -.1)) - expect_error(arx_args_list(quantile_levels = 1.1)) + expect_snapshot(error = TRUE, arx_args_list(quantile_levels = -.1)) + expect_snapshot(error = TRUE, arx_args_list(quantile_levels = 1.1)) expect_type(arx_args_list(quantile_levels = NULL), "list") - expect_error(arx_args_list(target_date = "2022-01-01")) + expect_snapshot(error = TRUE, arx_args_list(target_date = "2022-01-01")) expect_identical( arx_args_list(target_date = as.Date("2022-01-01"))$target_date, as.Date("2022-01-01") ) - expect_error(arx_args_list(n_training_min = "de")) - expect_error(arx_args_list(epi_keys = 1)) + expect_snapshot(error = TRUE, arx_args_list(n_training_min = "de")) + expect_snapshot(error = TRUE, arx_args_list(epi_keys = 1)) expect_warning(arx_args_list( forecast_date = as.Date("2022-01-01"), @@ -58,7 +58,7 @@ test_that("arx forecaster disambiguates quantiles", { sort(unique(tlist)) ) alist <- c(.1, .3, .5, .7, .9) # neither default, and different, - expect_error(compare_quantile_args(alist, tlist)) + expect_snapshot(error = TRUE, compare_quantile_args(alist, tlist)) }) test_that("arx_lags_validator handles named & unnamed lists as expected", { @@ -94,7 +94,7 @@ test_that("arx_lags_validator handles named & unnamed lists as expected", { ) # More lags than predictors - Error - expect_error(arx_lags_validator(pred_vec, lags_finit_fn_switch2)) + expect_snapshot(error = TRUE, arx_lags_validator(pred_vec, lags_finit_fn_switch2)) # Unnamed list of lags lags_init_un <- list(c(0, 7, 14), c(0, 1, 2, 3, 7, 14)) @@ -115,5 +115,5 @@ test_that("arx_lags_validator handles named & unnamed lists as expected", { # Try use a name not in predictors - Error lags_init_other_name <- list(death_rate = c(0, 7, 14), test_var = c(0, 1, 2, 3, 7, 14)) - expect_error(arx_lags_validator(pred_vec, lags_init_other_name)) + expect_snapshot(error = TRUE, arx_lags_validator(pred_vec, lags_init_other_name)) }) diff --git a/tests/testthat/test-arx_cargs_list.R b/tests/testthat/test-arx_cargs_list.R index d225cf62a..12087e45f 100644 --- a/tests/testthat/test-arx_cargs_list.R +++ b/tests/testthat/test-arx_cargs_list.R @@ -1,24 +1,24 @@ test_that("arx_class_args checks inputs", { expect_s3_class(arx_class_args_list(), c("arx_class", "alist")) - expect_error(arx_class_args_list(ahead = c(0, 4))) - expect_error(arx_class_args_list(n_training = c(28, 65))) + expect_snapshot(error = TRUE, arx_class_args_list(ahead = c(0, 4))) + expect_snapshot(error = TRUE, arx_class_args_list(n_training = c(28, 65))) - expect_error(arx_class_args_list(ahead = -1)) - expect_error(arx_class_args_list(ahead = 1.5)) - expect_error(arx_class_args_list(n_training = -1)) - expect_error(arx_class_args_list(n_training = 1.5)) - expect_error(arx_class_args_list(lags = c(-1, 0))) - expect_error(arx_class_args_list(lags = list(c(1:5, 6.5), 2:8))) + expect_snapshot(error = TRUE, arx_class_args_list(ahead = -1)) + expect_snapshot(error = TRUE, arx_class_args_list(ahead = 1.5)) + expect_snapshot(error = TRUE, arx_class_args_list(n_training = -1)) + expect_snapshot(error = TRUE, arx_class_args_list(n_training = 1.5)) + expect_snapshot(error = TRUE, arx_class_args_list(lags = c(-1, 0))) + expect_snapshot(error = TRUE, arx_class_args_list(lags = list(c(1:5, 6.5), 2:8))) - expect_error(arx_class_args_list(target_date = "2022-01-01")) + expect_snapshot(error = TRUE, arx_class_args_list(target_date = "2022-01-01")) expect_identical( arx_class_args_list(target_date = as.Date("2022-01-01"))$target_date, as.Date("2022-01-01") ) - expect_error(arx_class_args_list(n_training_min = "de")) - expect_error(arx_class_args_list(epi_keys = 1)) + expect_snapshot(error = TRUE, arx_class_args_list(n_training_min = "de")) + expect_snapshot(error = TRUE, arx_class_args_list(epi_keys = 1)) expect_warning(arx_class_args_list( forecast_date = as.Date("2022-01-01"), diff --git a/tests/testthat/test-bake-method.R b/tests/testthat/test-bake-method.R index 0e2746cf2..06f861012 100644 --- a/tests/testthat/test-bake-method.R +++ b/tests/testthat/test-bake-method.R @@ -25,5 +25,5 @@ test_that("bake method works in all cases", { expect_s3_class(bake(prep(r, edf), NULL, composition = "tibble"), "tbl_df") expect_s3_class(bake(prep(r, edf), NULL, composition = "data.frame"), "data.frame") # can't be a matrix because time_value/geo_value aren't numeric - expect_error(bake(prep(r, edf), NULL, composition = "matrix")) + expect_snapshot(error = TRUE, bake(prep(r, edf), NULL, composition = "matrix")) }) diff --git a/tests/testthat/test-check-training-set.R b/tests/testthat/test-check-training-set.R index 0f9246282..64d4d6945 100644 --- a/tests/testthat/test-check-training-set.R +++ b/tests/testthat/test-check-training-set.R @@ -7,7 +7,7 @@ test_that("training set validation works", { expect_silent(validate_meta_match(template, template, "time_type", "blah")) attr(t1, "metadata")$geo_type <- "county" expect_warning(validate_meta_match(t1, template, "geo_type"), "county") - expect_error(validate_meta_match(t1, template, "geo_type", "abort"), "county") + expect_snapshot(error = TRUE, validate_meta_match(t1, template, "geo_type", "abort")) expect_identical(template, epi_check_training_set(template, rec)) @@ -25,5 +25,5 @@ test_that("training set validation works", { expect_warning(t4 <- epi_check_training_set(t3, rec)) expect_identical(rec$template, t4) attr(rec$template, "metadata")$other_keys <- "missing_col" - expect_error(epi_check_training_set(t4, rec), "missing_col") + expect_snapshot(error = TRUE, epi_check_training_set(t4, rec)) }) diff --git a/tests/testthat/test-check_enough_train_data.R b/tests/testthat/test-check_enough_train_data.R index 502ea06f1..9b2ef5f34 100644 --- a/tests/testthat/test-check_enough_train_data.R +++ b/tests/testthat/test-check_enough_train_data.R @@ -23,15 +23,16 @@ test_that("check_enough_train_data works on pooled data", { bake(new_data = NULL) ) # Check both column don't have enough data - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, drop_na = FALSE) %>% prep(toy_epi_df) %>% - bake(new_data = NULL), - regexp = "The following columns don't have enough data" + bake(new_data = NULL) ) # Check drop_na works - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, drop_na = TRUE) %>% prep(toy_epi_df) %>% @@ -48,15 +49,16 @@ test_that("check_enough_train_data works on unpooled data", { bake(new_data = NULL) ) # Check one column don't have enough data - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", drop_na = FALSE) %>% prep(toy_epi_df) %>% - bake(new_data = NULL), - regexp = "The following columns don't have enough data" + bake(new_data = NULL) ) # Check drop_na works - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, epi_keys = "geo_value", drop_na = TRUE) %>% prep(toy_epi_df) %>% @@ -114,7 +116,8 @@ test_that("check_enough_train_data works with all_predictors() downstream of con prep(toy_epi_df) %>% bake(new_data = NULL) ) - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% check_enough_train_data(all_predictors(), y, n = 2 * n - 5) %>% diff --git a/tests/testthat/test-dist_quantiles.R b/tests/testthat/test-dist_quantiles.R index 66456ef80..8112326dc 100644 --- a/tests/testthat/test-dist_quantiles.R +++ b/tests/testthat/test-dist_quantiles.R @@ -1,13 +1,13 @@ library(distributional) test_that("constructor returns reasonable quantiles", { - expect_error(new_quantiles(rnorm(5), rnorm(5))) + expect_snapshot(error = TRUE, new_quantiles(rnorm(5), rnorm(5))) expect_silent(new_quantiles(sort(rnorm(5)), sort(runif(5)))) - expect_error(new_quantiles(sort(rnorm(5)), sort(runif(2)))) + expect_snapshot(error = TRUE, new_quantiles(sort(rnorm(5)), sort(runif(2)))) expect_silent(new_quantiles(1:5, 1:5 / 10)) - expect_error(new_quantiles(c(2, 1, 3, 4, 5), c(.1, .1, .2, .5, .8))) - expect_error(new_quantiles(c(2, 1, 3, 4, 5), c(.1, .15, .2, .5, .8))) - expect_error(new_quantiles(c(1, 2, 3), c(.1, .2, 3))) + expect_snapshot(error = TRUE, new_quantiles(c(2, 1, 3, 4, 5), c(.1, .1, .2, .5, .8))) + expect_snapshot(error = TRUE, new_quantiles(c(2, 1, 3, 4, 5), c(.1, .15, .2, .5, .8))) + expect_snapshot(error = TRUE, new_quantiles(c(1, 2, 3), c(.1, .2, 3))) }) @@ -106,6 +106,6 @@ test_that("arithmetic works on quantiles", { expect_identical(dstn / 4, dstn2) expect_identical((1 / 4) * dstn, dstn2) - expect_error(sum(dstn)) - expect_error(suppressWarnings(dstn + distributional::dist_normal())) + expect_snapshot(error = TRUE, sum(dstn)) + expect_snapshot(error = TRUE, suppressWarnings(dstn + distributional::dist_normal())) }) diff --git a/tests/testthat/test-enframer.R b/tests/testthat/test-enframer.R index c555ea9b2..0926c587b 100644 --- a/tests/testthat/test-enframer.R +++ b/tests/testthat/test-enframer.R @@ -1,11 +1,11 @@ test_that("enframer errors/works as needed", { template1 <- data.frame(aa = 1:5, a = NA, b = NA, c = NA) template2 <- data.frame(aa = 1:5, a = 2:6, b = 2:6, c = 2:6) - expect_error(enframer(1:5, letters[1])) - expect_error(enframer(data.frame(a = 1:5), 1:3)) - expect_error(enframer(data.frame(a = 1:5), letters[1:3])) + expect_snapshot(error = TRUE, enframer(1:5, letters[1])) + expect_snapshot(error = TRUE, enframer(data.frame(a = 1:5), 1:3)) + expect_snapshot(error = TRUE, enframer(data.frame(a = 1:5), letters[1:3])) expect_identical(enframer(data.frame(aa = 1:5), letters[1:3]), template1) - expect_error(enframer(data.frame(aa = 1:5), letters[1:2], fill = 1:4)) + expect_snapshot(error = TRUE, enframer(data.frame(aa = 1:5), letters[1:2], fill = 1:4)) expect_identical( enframer(data.frame(aa = 1:5), letters[1:3], fill = 2:6), template2 diff --git a/tests/testthat/test-epi_recipe.R b/tests/testthat/test-epi_recipe.R index f8933b018..1b06cf24c 100644 --- a/tests/testthat/test-epi_recipe.R +++ b/tests/testthat/test-epi_recipe.R @@ -155,6 +155,6 @@ test_that("add/update/adjust/remove epi_recipe works as intended", { wf <- remove_epi_recipe(wf) - expect_error(workflows::extract_preprocessor(wf)$steps) + expect_snapshot(error = TRUE, workflows::extract_preprocessor(wf)$steps) expect_equal(wf$pre$actions$recipe$recipe, NULL) }) diff --git a/tests/testthat/test-epi_workflow.R b/tests/testthat/test-epi_workflow.R index 01eff4209..8bb58b0bc 100644 --- a/tests/testthat/test-epi_workflow.R +++ b/tests/testthat/test-epi_workflow.R @@ -59,7 +59,7 @@ test_that("model can be added/updated/removed from epi_workflow", { expect_equal(class(model_spec2), c("linear_reg", "model_spec")) wf <- remove_model(wf) - expect_error(extract_spec_parsnip(wf)) + expect_snapshot(error = TRUE, extract_spec_parsnip(wf)) expect_equal(wf$fit$actions$model$spec, NULL) }) @@ -103,7 +103,7 @@ test_that("forecast method errors when workflow not fit", { step_epi_naomit() wf <- epi_workflow(r, parsnip::linear_reg()) - expect_error(forecast(wf)) + expect_snapshot(error = TRUE, forecast(wf)) }) test_that("fit method does not silently drop the class", { diff --git a/tests/testthat/test-extract_argument.R b/tests/testthat/test-extract_argument.R index 3250b2991..7434763e7 100644 --- a/tests/testthat/test-extract_argument.R +++ b/tests/testthat/test-extract_argument.R @@ -4,27 +4,27 @@ test_that("layer argument extractor works", { layer_residual_quantiles(quantile_levels = c(0.0275, 0.975), symmetrize = FALSE) %>% layer_naomit(.pred) - expect_error(extract_argument(f$layers[[1]], "uhoh", "bubble")) - expect_error(extract_argument(f$layers[[1]], "layer_predict", "bubble")) + expect_snapshot(error = TRUE, extract_argument(f$layers[[1]], "uhoh", "bubble")) + expect_snapshot(error = TRUE, extract_argument(f$layers[[1]], "layer_predict", "bubble")) expect_identical( extract_argument(f$layers[[2]], "layer_residual_quantiles", "quantile_levels"), c(0.0275, 0.9750) ) - expect_error(extract_argument(f, "layer_thresh", "quantile_levels")) + expect_snapshot(error = TRUE, extract_argument(f, "layer_thresh", "quantile_levels")) expect_identical( extract_argument(f, "layer_residual_quantiles", "quantile_levels"), c(0.0275, 0.9750) ) wf <- epi_workflow(postprocessor = f) - expect_error(extract_argument(epi_workflow(), "layer_residual_quantiles", "quantile_levels")) + expect_snapshot(error = TRUE, extract_argument(epi_workflow(), "layer_residual_quantiles", "quantile_levels")) expect_identical( extract_argument(wf, "layer_residual_quantiles", "quantile_levels"), c(0.0275, 0.9750) ) - expect_error(extract_argument(wf, "layer_predict", c("type", "opts"))) + expect_snapshot(error = TRUE, extract_argument(wf, "layer_predict", c("type", "opts"))) }) test_that("recipe argument extractor works", { @@ -41,19 +41,19 @@ test_that("recipe argument extractor works", { step_naomit(all_outcomes(), skip = TRUE) - expect_error(extract_argument(r$steps[[1]], "uhoh", "bubble")) - expect_error(extract_argument(r$steps[[1]], "step_epi_lag", "bubble")) + expect_snapshot(error = TRUE, extract_argument(r$steps[[1]], "uhoh", "bubble")) + expect_snapshot(error = TRUE, extract_argument(r$steps[[1]], "step_epi_lag", "bubble")) expect_identical(extract_argument(r$steps[[2]], "step_epi_ahead", "ahead"), 7L) - expect_error(extract_argument(r, "step_lightly", "quantile_levels")) + expect_snapshot(error = TRUE, extract_argument(r, "step_lightly", "quantile_levels")) expect_identical( extract_argument(r, "step_epi_lag", "lag"), list(c(0L, 7L, 14L), c(0L, 7L, 14L)) ) wf <- epi_workflow(preprocessor = r) - expect_error(extract_argument(epi_workflow(), "step_epi_lag", "lag")) + expect_snapshot(error = TRUE, extract_argument(epi_workflow(), "step_epi_lag", "lag")) expect_identical( extract_argument(wf, "step_epi_lag", "lag"), list(c(0L, 7L, 14L), c(0L, 7L, 14L)) diff --git a/tests/testthat/test-flatline_args_list.R b/tests/testthat/test-flatline_args_list.R index 86f42a208..6359afc27 100644 --- a/tests/testthat/test-flatline_args_list.R +++ b/tests/testthat/test-flatline_args_list.R @@ -1,30 +1,30 @@ test_that("flatline_args_list checks inputs", { expect_s3_class(flatline_args_list(), c("flat_fcast", "alist")) - expect_error(flatline_args_list(ahead = c(0, 4))) - expect_error(flatline_args_list(n_training = c(28, 65))) + expect_snapshot(error = TRUE, flatline_args_list(ahead = c(0, 4))) + expect_snapshot(error = TRUE, flatline_args_list(n_training = c(28, 65))) - expect_error(flatline_args_list(ahead = -1)) - expect_error(flatline_args_list(ahead = 1.5)) - expect_error(flatline_args_list(n_training = -1)) - expect_error(flatline_args_list(n_training = 1.5)) - expect_error(flatline_args_list(lags = c(-1, 0))) - expect_error(flatline_args_list(lags = list(c(1:5, 6.5), 2:8))) + expect_snapshot(error = TRUE, flatline_args_list(ahead = -1)) + expect_snapshot(error = TRUE, flatline_args_list(ahead = 1.5)) + expect_snapshot(error = TRUE, flatline_args_list(n_training = -1)) + expect_snapshot(error = TRUE, flatline_args_list(n_training = 1.5)) + expect_snapshot(error = TRUE, flatline_args_list(lags = c(-1, 0))) + expect_snapshot(error = TRUE, flatline_args_list(lags = list(c(1:5, 6.5), 2:8))) - expect_error(flatline_args_list(symmetrize = 4)) - expect_error(flatline_args_list(nonneg = 4)) + expect_snapshot(error = TRUE, flatline_args_list(symmetrize = 4)) + expect_snapshot(error = TRUE, flatline_args_list(nonneg = 4)) - expect_error(flatline_args_list(quantile_levels = -.1)) - expect_error(flatline_args_list(quantile_levels = 1.1)) + expect_snapshot(error = TRUE, flatline_args_list(quantile_levels = -.1)) + expect_snapshot(error = TRUE, flatline_args_list(quantile_levels = 1.1)) expect_type(flatline_args_list(quantile_levels = NULL), "list") - expect_error(flatline_args_list(target_date = "2022-01-01")) + expect_snapshot(error = TRUE, flatline_args_list(target_date = "2022-01-01")) expect_identical( flatline_args_list(target_date = as.Date("2022-01-01"))$target_date, as.Date("2022-01-01") ) - expect_error(flatline_args_list(n_training_min = "de")) - expect_error(flatline_args_list(epi_keys = 1)) + expect_snapshot(error = TRUE, flatline_args_list(n_training_min = "de")) + expect_snapshot(error = TRUE, flatline_args_list(epi_keys = 1)) # Detect mismatched ahead and target_date - forecast_date difference expect_warning(flatline_args_list( diff --git a/tests/testthat/test-frosting.R b/tests/testthat/test-frosting.R index 5cab9c494..1bdce3b5a 100644 --- a/tests/testthat/test-frosting.R +++ b/tests/testthat/test-frosting.R @@ -7,7 +7,7 @@ test_that("frosting validators / constructors work", { expect_false(has_postprocessor_frosting(wf)) expect_silent(wf %>% add_frosting(new_frosting())) expect_silent(wf %>% add_postprocessor(new_frosting())) - expect_error(wf %>% add_postprocessor(list())) + expect_snapshot(error = TRUE, wf %>% add_postprocessor(list())) wf <- wf %>% add_frosting(new_frosting()) expect_true(has_postprocessor(wf)) @@ -16,7 +16,7 @@ test_that("frosting validators / constructors work", { test_that("frosting can be created/added/updated/adjusted/removed", { f <- frosting() - expect_error(frosting(layers = 1:5)) + expect_snapshot(error = TRUE, frosting(layers = 1:5)) wf <- epi_workflow() %>% add_frosting(f) expect_true(has_postprocessor_frosting(wf)) wf1 <- update_frosting(wf, frosting() %>% layer_predict() %>% layer_threshold(.pred)) diff --git a/tests/testthat/test-get_test_data.R b/tests/testthat/test-get_test_data.R index 035fc6463..aa799150b 100644 --- a/tests/testthat/test-get_test_data.R +++ b/tests/testthat/test-get_test_data.R @@ -25,7 +25,7 @@ test_that("expect insufficient training data error", { step_naomit(all_predictors()) %>% step_naomit(all_outcomes(), skip = TRUE) - expect_error(get_test_data(recipe = r, x = case_death_rate_subset)) + expect_snapshot(error = TRUE, get_test_data(recipe = r, x = case_death_rate_subset)) }) @@ -39,7 +39,7 @@ test_that("expect error that geo_value or time_value does not exist", { wrong_epi_df <- case_death_rate_subset %>% dplyr::select(-geo_value) - expect_error(get_test_data(recipe = r, x = wrong_epi_df)) + expect_snapshot(error = TRUE, get_test_data(recipe = r, x = wrong_epi_df)) }) @@ -60,15 +60,15 @@ test_that("NA fill behaves as desired", { expect_silent(tt <- get_test_data(r, df)) expect_s3_class(tt, "epi_df") - expect_error(get_test_data(r, df, "A")) - expect_error(get_test_data(r, df, TRUE, -3)) + expect_snapshot(error = TRUE, get_test_data(r, df, "A")) + expect_snapshot(error = TRUE, get_test_data(r, df, TRUE, -3)) df2 <- df df2$x1[df2$geo_value == "ca"] <- NA td <- get_test_data(r, df2) expect_true(any(is.na(td))) - expect_error(get_test_data(r, df2, TRUE)) + expect_snapshot(error = TRUE, get_test_data(r, df2, TRUE)) df1 <- df2 df1$x1[1:4] <- 1:4 @@ -93,9 +93,9 @@ test_that("forecast date behaves", { step_epi_ahead(x1, ahead = 3) %>% step_epi_lag(x1, x2, lag = c(1, 3)) - expect_error(get_test_data(r, df, TRUE, forecast_date = 9)) # class error - expect_error(get_test_data(r, df, TRUE, forecast_date = 9L)) # fd too early - expect_error(get_test_data(r, df, forecast_date = 9L)) # fd too early + expect_snapshot(error = TRUE, get_test_data(r, df, TRUE, forecast_date = 9)) # class error + expect_snapshot(error = TRUE, get_test_data(r, df, TRUE, forecast_date = 9L)) # fd too early + expect_snapshot(error = TRUE, get_test_data(r, df, forecast_date = 9L)) # fd too early ndf <- get_test_data(r, df, TRUE, forecast_date = 12L) expect_equal(max(ndf$time_value), 11L) # max lag was 1 diff --git a/tests/testthat/test-layer_add_forecast_date.R b/tests/testthat/test-layer_add_forecast_date.R index 6d0e637c8..428922f46 100644 --- a/tests/testthat/test-layer_add_forecast_date.R +++ b/tests/testthat/test-layer_add_forecast_date.R @@ -11,9 +11,9 @@ latest <- jhu %>% test_that("layer validation works", { f <- frosting() - expect_error(layer_add_forecast_date(f, c("2022-05-31", "2022-05-31"))) # multiple forecast_dates - expect_error(layer_add_forecast_date(f, "2022-05-31", id = 2)) # id is not a character - expect_error(layer_add_forecast_date(f, "2022-05-31", id = c("a", "b"))) # multiple ids + expect_snapshot(error = TRUE, layer_add_forecast_date(f, c("2022-05-31", "2022-05-31"))) # multiple forecast_dates + expect_snapshot(error = TRUE, layer_add_forecast_date(f, "2022-05-31", id = 2)) # id is not a character + expect_snapshot(error = TRUE, layer_add_forecast_date(f, "2022-05-31", id = c("a", "b"))) # multiple ids expect_silent(layer_add_forecast_date(f, "2022-05-31")) expect_silent(layer_add_forecast_date(f)) expect_silent(layer_add_forecast_date(f, as.Date("2022-05-31"))) @@ -96,7 +96,7 @@ test_that("forecast date works for daily", { group_by(geo_value, time_value) %>% summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups = "drop") %>% as_epi_df() - expect_error(predict(wf1, latest_yearly)) + expect_snapshot(error = TRUE, predict(wf1, latest_yearly)) # forecast_date is a string, gets correctly converted to date wf2 <- add_frosting( @@ -110,5 +110,5 @@ test_that("forecast date works for daily", { wf, adjust_frosting(f, "layer_add_forecast_date", forecast_date = 2022L) ) - expect_error(predict(wf3, latest)) + expect_snapshot(error = TRUE, predict(wf3, latest)) }) diff --git a/tests/testthat/test-layer_add_target_date.R b/tests/testthat/test-layer_add_target_date.R index f1fa3f217..53506ad07 100644 --- a/tests/testthat/test-layer_add_target_date.R +++ b/tests/testthat/test-layer_add_target_date.R @@ -107,7 +107,7 @@ test_that("target date works for daily and yearly", { group_by(geo_value, time_value) %>% summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups = "drop") %>% as_epi_df() - expect_error(predict(wf1, latest_bad)) + expect_snapshot(error = TRUE, predict(wf1, latest_bad)) # target_date is a string (gets correctly converted to Date) wf1 <- add_frosting( diff --git a/tests/testthat/test-layer_predict.R b/tests/testthat/test-layer_predict.R index 041516b29..70e76e593 100644 --- a/tests/testthat/test-layer_predict.R +++ b/tests/testthat/test-layer_predict.R @@ -48,7 +48,7 @@ test_that("layer_predict dots validation", { # We don't detect completely-bogus arg names until predict time: expect_no_error(f_bad_arg <- frosting() %>% layer_predict(bogus_argument = "something")) wf_bad_arg <- wf %>% add_frosting(f_bad_arg) - expect_error(predict(wf_bad_arg, latest)) + expect_snapshot(error = TRUE, predict(wf_bad_arg, latest)) # ^ (currently with a awful error message, due to an extra comma in parsnip::check_pred_type_dots) # Some argument names only apply for some prediction `type`s; we don't check diff --git a/tests/testthat/test-layer_residual_quantiles.R b/tests/testthat/test-layer_residual_quantiles.R index e3668b249..09ef7c9d3 100644 --- a/tests/testthat/test-layer_residual_quantiles.R +++ b/tests/testthat/test-layer_residual_quantiles.R @@ -46,7 +46,7 @@ test_that("Errors when used with a classifier", { layer_predict() %>% layer_residual_quantiles() wf <- wf %>% add_frosting(f) - expect_error(forecast(wf)) + expect_snapshot(error = TRUE, forecast(wf)) }) @@ -99,8 +99,8 @@ test_that("Canned forecasters work with / without", { }) test_that("flatline_forecaster correctly errors when n_training < ahead", { - expect_error( - flatline_forecaster(jhu, "death_rate", args_list = flatline_args_list(ahead = 10, n_training = 9)), - "This may be due to `n_train` < `ahead`" + expect_snapshot( + error = TRUE, + flatline_forecaster(jhu, "death_rate", args_list = flatline_args_list(ahead = 10, n_training = 9)) ) }) diff --git a/tests/testthat/test-layers.R b/tests/testthat/test-layers.R index 13f859ac3..6e2d80111 100644 --- a/tests/testthat/test-layers.R +++ b/tests/testthat/test-layers.R @@ -11,7 +11,7 @@ test_that("A layer can be updated in frosting", { expect_equal(length(f$layers), 2) expect_equal(f$layers[[1]], fold$layers[[1]]) expect_equal(f$layers[[2]]$lower, 100) - expect_error(update(f$layers[[1]], lower = 100)) - expect_error(update(f$layers[[3]], lower = 100)) - expect_error(update(f$layers[[2]], bad_param = 100)) + expect_snapshot(error = TRUE, update(f$layers[[1]], lower = 100)) + expect_snapshot(error = TRUE, update(f$layers[[3]], lower = 100)) + expect_snapshot(error = TRUE, update(f$layers[[2]], bad_param = 100)) }) diff --git a/tests/testthat/test-parse_period.R b/tests/testthat/test-parse_period.R index 0adbcec3d..10dd5692d 100644 --- a/tests/testthat/test-parse_period.R +++ b/tests/testthat/test-parse_period.R @@ -1,8 +1,8 @@ test_that("parse_period works", { - expect_error(parse_period(c(1, 2))) - expect_error(parse_period(c(1.3))) - expect_error(parse_period("1 year")) - expect_error(parse_period("2 weeks later")) + expect_snapshot(error = TRUE, parse_period(c(1, 2))) + expect_snapshot(error = TRUE, parse_period(c(1.3))) + expect_snapshot(error = TRUE, parse_period("1 year")) + expect_snapshot(error = TRUE, parse_period("2 weeks later")) expect_identical(parse_period(1), 1L) expect_identical(parse_period("1 day"), 1L) expect_identical(parse_period("1 days"), 1L) diff --git a/tests/testthat/test-parsnip_model_validation.R b/tests/testthat/test-parsnip_model_validation.R index 02ed94fe0..605fad817 100644 --- a/tests/testthat/test-parsnip_model_validation.R +++ b/tests/testthat/test-parsnip_model_validation.R @@ -4,12 +4,12 @@ test_that("forecaster can validate parsnip model", { trainer2 <- parsnip::logistic_reg() trainer3 <- parsnip::rand_forest() - expect_error(get_parsnip_mode(l)) + expect_snapshot(error = TRUE, get_parsnip_mode(l)) expect_equal(get_parsnip_mode(trainer1), "regression") expect_equal(get_parsnip_mode(trainer2), "classification") expect_equal(get_parsnip_mode(trainer3), "unknown") - expect_error(is_classification(l)) + expect_snapshot(error = TRUE, is_classification(l)) expect_true(is_regression(trainer1)) expect_false(is_classification(trainer1)) expect_true(is_classification(trainer2)) diff --git a/tests/testthat/test-pivot_quantiles.R b/tests/testthat/test-pivot_quantiles.R index d1f092c0e..1639058e2 100644 --- a/tests/testthat/test-pivot_quantiles.R +++ b/tests/testthat/test-pivot_quantiles.R @@ -1,14 +1,14 @@ test_that("quantile pivotting wider behaves", { tib <- tibble::tibble(a = 1:5, b = 6:10) - expect_error(pivot_quantiles_wider(tib, a)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, a)) tib$c <- rep(dist_normal(), 5) - expect_error(pivot_quantiles_wider(tib, c)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, c)) d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:5, 1:4 / 5)) # different quantiles tib <- tib[1:2, ] tib$d1 <- d1 - expect_error(pivot_quantiles_wider(tib, d1)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, d1)) d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 2:4 / 4)) tib$d1 <- d1 @@ -36,9 +36,9 @@ test_that("pivotting wider still works if there are duplicates", { test_that("quantile pivotting longer behaves", { tib <- tibble::tibble(a = 1:5, b = 6:10) - expect_error(pivot_quantiles_longer(tib, a)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, a)) tib$c <- rep(dist_normal(), 5) - expect_error(pivot_quantiles_longer(tib, c)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, c)) d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:5, 1:4 / 5)) # different quantiles @@ -64,7 +64,7 @@ test_that("quantile pivotting longer behaves", { tib$d3 <- c(dist_quantiles(2:5, 2:5 / 6), dist_quantiles(3:6, 2:5 / 6)) # now the cols have different numbers of quantiles - expect_error(pivot_quantiles_longer(tib, d1, d3)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, d1, d3)) expect_length( pivot_quantiles_longer(tib, d1, d3, .ignore_length_check = TRUE), 6L diff --git a/tests/testthat/test-population_scaling.R b/tests/testthat/test-population_scaling.R index a94b40b82..6337a2ea8 100644 --- a/tests/testthat/test-population_scaling.R +++ b/tests/testthat/test-population_scaling.R @@ -279,7 +279,8 @@ test_that("expect error if `by` selector does not match", { df_pop_col = "values" ) - expect_error( + expect_snapshot( + error = TRUE, wf <- epi_workflow(r, parsnip::linear_reg()) %>% fit(jhu) %>% add_frosting(f) @@ -311,7 +312,7 @@ test_that("expect error if `by` selector does not match", { fit(jhu) %>% add_frosting(f) - expect_error(forecast(wf)) + expect_snapshot(error = TRUE, forecast(wf)) }) diff --git a/tests/testthat/test-shuffle.R b/tests/testthat/test-shuffle.R index 94bc1aa3b..f05e8be3d 100644 --- a/tests/testthat/test-shuffle.R +++ b/tests/testthat/test-shuffle.R @@ -1,5 +1,5 @@ test_that("shuffle works", { - expect_error(shuffle(matrix(NA, 2, 2))) + expect_snapshot(error = TRUE, shuffle(matrix(NA, 2, 2))) expect_length(shuffle(1:10), 10L) expect_identical(sort(shuffle(1:10)), 1:10) }) diff --git a/tests/testthat/test-step_epi_slide.R b/tests/testthat/test-step_epi_slide.R index c1e72501d..27f362ad6 100644 --- a/tests/testthat/test-step_epi_slide.R +++ b/tests/testthat/test-step_epi_slide.R @@ -31,6 +31,8 @@ test_that("epi_slide errors when needed", { # function problems expect_snapshot(error = TRUE, r %>% step_epi_slide(value)) expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = 1)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = 1)) }) diff --git a/tests/testthat/test-wis-dist-quantiles.R b/tests/testthat/test-wis-dist-quantiles.R index 93f7c50eb..937793189 100644 --- a/tests/testthat/test-wis-dist-quantiles.R +++ b/tests/testthat/test-wis-dist-quantiles.R @@ -26,7 +26,7 @@ test_that("wis dispatches and produces the correct values", { ) # errors for non distributions - expect_error(weighted_interval_score(1:10, 10)) + expect_snapshot(error = TRUE, weighted_interval_score(1:10, 10)) expect_warning(w <- weighted_interval_score(dist_normal(1), 10)) expect_true(all(is.na(w))) expect_warning(w <- weighted_interval_score( @@ -36,7 +36,7 @@ test_that("wis dispatches and produces the correct values", { expect_equal(w, c(NA, wis_one_pred(1:5, 1:5 / 6, 10))) # errors if sizes don't match - expect_error(weighted_interval_score( + expect_snapshot(error = TRUE, weighted_interval_score( dist_quantiles(list(1:4, 8:11), 1:4 / 5), # length 2 1:3 )) From aa418276c345319360eacabd1e6c9e9aa6e2305e Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Mon, 30 Sep 2024 16:24:26 -0700 Subject: [PATCH 3/3] bump version, promote authors, add funder --- DESCRIPTION | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c76280d45..5cd468fb9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,13 +1,14 @@ Package: epipredict Title: Basic epidemiology forecasting methods -Version: 0.0.24 +Version: 0.1.0 Authors@R: c( - person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), + person("Daniel J.", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"), + person("Dmitry", "Shemetov", email = "dshemeto@andrew.cmu.edu", role = "aut"), + person("David", "Weber", email = "davidweb@andrew.cmu.edu", role = "aut"), + person("CMU's Delphi Research Group", role = c("cph", "fnd")), person("Logan", "Brooks", role = "aut"), person("Rachel", "Lobay", role = "aut"), - person("Dmitry", "Shemetov", email = "dshemeto@andrew.cmu.edu", role = "ctb"), - person("David", "Weber", email = "davidweb@andrew.cmu.edu", role = "ctb"), person("Maggie", "Liu", role = "ctb"), person("Ken", "Mawer", role = "ctb"), person("Chloe", "You", role = "ctb"),