From 4d8a24dd45735ae77ba754af169ede46b0e41fa0 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Fri, 13 Sep 2024 15:47:00 -0700 Subject: [PATCH 01/10] import rlang checks since checkmate doesn't take an environment --- DESCRIPTION | 2 +- NAMESPACE | 13 + R/epipredict-package.R | 25 +- R/import-standalone-obj-type.R | 363 ++++++++++++++++++++ R/import-standalone-types-check.R | 553 ++++++++++++++++++++++++++++++ 5 files changed, 945 insertions(+), 11 deletions(-) create mode 100644 R/import-standalone-obj-type.R create mode 100644 R/import-standalone-types-check.R diff --git a/DESCRIPTION b/DESCRIPTION index 6d1217587..bccba8ece 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,7 +37,7 @@ Imports: hardhat (>= 1.3.0), magrittr, recipes (>= 1.0.4), - rlang (>= 1.0.0), + rlang (>= 1.1.0), stats, tibble, tidyr, diff --git a/NAMESPACE b/NAMESPACE index 23c5adeaf..1a1d3af18 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -272,15 +272,28 @@ importFrom(rlang,":=") importFrom(rlang,abort) importFrom(rlang,arg_match) importFrom(rlang,as_function) +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 6460b65e4..0aaf5f0c1 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,15 +1,20 @@ ## usethis namespace: start -#' @importFrom tibble as_tibble +#' @import epiprocess parsnip +#' @importFrom checkmate assert assert_character assert_int assert_scalar +#' @importFrom checkmate assert_integerish assert_date assert_function +#' @importFrom checkmate assert_class assert_logical assert_numeric assert_number +#' @importFrom checkmate assert_integer +#' @importFrom cli cli_abort cli_warn +#' @importFrom dplyr relocate summarise summarize everything +#' @importFrom dplyr filter mutate select left_join rename ungroup full_join +#' @importFrom dplyr arrange across all_of any_of bind_cols bind_rows group_by +#' @importFrom rlang is_logical is_true inject enquo enquos expr sym arg_match #' @importFrom rlang := !! %||% as_function global_env set_names !!! -#' is_logical is_true inject enquo enquos expr sym arg_match +#' @importFrom rlang caller_arg is_missing is_string is_symbol is_call +#' @importFrom rlang env_get_list is_environment is_function is_closure is_formula +#' @importFrom rlang is_character is_vector is_list #' @importFrom stats poly predict lm residuals quantile -#' @importFrom dplyr arrange across all_of any_of bind_cols bind_rows group_by -#' summarize filter mutate select left_join rename ungroup full_join -#' relocate summarise everything -#' @importFrom cli cli_abort cli_warn -#' @importFrom checkmate assert assert_character assert_int assert_scalar -#' assert_logical assert_numeric assert_number assert_integer -#' assert_integerish assert_date assert_function assert_class -#' @import epiprocess parsnip +#' @importFrom tibble as_tibble +na_chr <- NA_character_ ## usethis namespace: end NULL diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R new file mode 100644 index 000000000..646aa33fc --- /dev/null +++ b/R/import-standalone-obj-type.R @@ -0,0 +1,363 @@ +# 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 new file mode 100644 index 000000000..1ca83997d --- /dev/null +++ b/R/import-standalone-types-check.R @@ -0,0 +1,553 @@ +# 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 From 73579e5cceb88395a463c06fc1a9907d3fe966db Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 19 Sep 2024 11:40:30 -0700 Subject: [PATCH 02/10] current tests pass --- R/utils-arg.R | 141 ++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 113 insertions(+), 28 deletions(-) diff --git a/R/utils-arg.R b/R/utils-arg.R index b4242eaf9..174d016d8 100644 --- a/R/utils-arg.R +++ b/R/utils-arg.R @@ -10,87 +10,172 @@ handle_arg_list <- function(..., .tests) { walk2(names, values, .tests) } -arg_is_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) { +arg_is_scalar <- function(..., allow_null = FALSE, allow_na = FALSE, + call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_scalar(value, null.ok = allow_null, na.ok = allow_na, .var.name = name) + ok <- test_scalar(value, null.ok = allow_null, na.ok = allow_na) + if (!ok) { + cli_abort("{.arg {name}} must be a scalar.", call = call) + } }) } -arg_is_lgl <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE) { +arg_is_lgl <- function(..., allow_null = FALSE, allow_na = FALSE, + allow_empty = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_logical(value, null.ok = allow_null, any.missing = allow_na, min.len = as.integer(!allow_empty), .var.name = name) + ok <- test_logical(value, null.ok = allow_null, any.missing = allow_na, + min.len = as.integer(!allow_empty)) + if (!ok) { + cli_abort("{.arg {name}} must be of type {.cls logical}.", call = call) + } }) } -arg_is_lgl_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) { +arg_is_lgl_scalar <- function(..., allow_null = FALSE, allow_na = FALSE, + call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_logical(value, null.ok = allow_null, any.missing = allow_na, min.len = 1, max.len = 1, .var.name = name) + ok <- test_logical(value, null.ok = allow_null, any.missing = allow_na, + min.len = 1, max.len = 1) + if (!ok) { + cli_abort( + "{.arg {name}} must be a scalar of type {.cls logical}.", + call = call + ) + } }) } -arg_is_numeric <- function(..., allow_null = FALSE) { +arg_is_numeric <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_numeric(value, null.ok = allow_null, any.missing = FALSE, .var.name = name) + ok <- test_numeric(value, null.ok = allow_null, any.missing = FALSE) + if (!ok) { + cli_abort("{.arg {name}} must be of type {.cls numeric}.", call = call) + } }) } -arg_is_pos <- function(..., allow_null = FALSE) { +arg_is_pos <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_numeric(value, lower = 1, null.ok = allow_null, any.missing = FALSE, .var.name = name) + ok <- test_numeric( + value, lower = .Machine$double.eps, + null.ok = allow_null, any.missing = FALSE + ) + if (!ok) { + len <- length(value) + cli_abort( + "{.arg {name}} must be {cli::qty(len)} {?a/} strictly positive number{?s}.", + call = call + ) + } }) } -arg_is_nonneg <- function(..., allow_null = FALSE) { +arg_is_nonneg <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_numeric(value, lower = 0, null.ok = allow_null, any.missing = FALSE, .var.name = name) + ok <- test_numeric(value, lower = 0, null.ok = allow_null, any.missing = FALSE) + if (!ok) { + len <- length(value) + cli_abort( + "{.arg {name}} must be {cli::qty(len)} {?a/} non-negative number{?s}.", + call = call + ) + } }) } -arg_is_int <- function(..., allow_null = FALSE) { +arg_is_int <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_integerish(value, null.ok = allow_null, .var.name = name) + ok <- test_integerish(value, null.ok = allow_null) + if (!ok) { + len <- length(value) + cli_abort( + "{.arg {name}} must be {cli::qty(len)} {?a/} integer{?s}.", + call = call + ) + } }) } -arg_is_pos_int <- function(..., allow_null = FALSE) { +arg_is_pos_int <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_integerish(value, null.ok = allow_null, lower = 1, any.missing = FALSE, .var.name = name) + ok <- test_integerish(value, null.ok = allow_null, lower = 1, any.missing = FALSE) + if (!ok) { + len <- length(value) + cli_abort( + "{.arg {name}} must be {cli::qty(len)} {?a/} positive integer{?s}.", + call = call + ) + } }) } -arg_is_nonneg_int <- function(..., allow_null = FALSE) { +arg_is_nonneg_int <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_integerish(value, null.ok = allow_null, lower = 0, any.missing = FALSE, .var.name = name) + ok <- test_integerish(value, null.ok = allow_null, lower = 0, any.missing = FALSE) + if (!ok) { + len <- length(value) + cli_abort( + "{.arg {name}} must be {cli::qty(len)} {?a/} non-negative integer{?s}.", + call = call + ) + } }) } -arg_is_date <- function(..., allow_null = FALSE) { +arg_is_date <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_date(value, null.ok = allow_null, .var.name = name) + ok <- test_date(value, null.ok = allow_null) + if (!ok) { + len <- length(value) + cli_abort( + "{.arg {name}} must be {cli::qty(len)} {?a/} date{?s}.", + call = call + ) + } }) } -arg_is_probabilities <- function(..., allow_null = FALSE, allow_na = FALSE) { +arg_is_probabilities <- function(..., allow_null = FALSE, allow_na = FALSE, + call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_numeric(value, lower = 0, upper = 1, null.ok = allow_null, any.missing = allow_na, .var.name = name) + ok <- test_numeric(value, lower = 0, upper = 1, null.ok = allow_null, + any.missing = allow_na) + if (!ok) { + cli_abort("{.arg {name}} must lie in [0, 1].", call = call) + } }) } -arg_is_chr <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE) { +arg_is_chr <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE, + call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_character(value, null.ok = allow_null, any.missing = allow_na, min.len = as.integer(!allow_empty), .var.name = name) + ok <- test_character(value, null.ok = allow_null, any.missing = allow_na, + min.len = as.integer(!allow_empty)) + if (!ok) { + cli_abort("{.arg {name}} must be of type {.cls character}.", call = call) + } }) } -arg_is_chr_scalar <- function(..., allow_null = FALSE, allow_na = FALSE) { +arg_is_chr_scalar <- function(..., allow_null = FALSE, allow_na = FALSE, + call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_character(value, null.ok = allow_null, any.missing = allow_na, min.len = 1, max.len = 1, .var.name = name) + ok <- test_character(value, null.ok = allow_null, any.missing = allow_na, + len = 1L) + if (!ok) { + cli_abort( + "{.arg {name}} must be a scalar of type {.cls character}.", + call = call) + } }) } -arg_is_function <- function(..., allow_null = FALSE) { +arg_is_function <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - assert_function(value, null.ok = allow_null, .var.name = name) + ok <- test_function(value, null.ok = allow_null) + if (!ok) { + cli_abort("{.arg {name}} must be of type {.cls function}.", call = call) + } }) } From 79c56fccf5338257d7f6079631aa4f4ba826bdee Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 19 Sep 2024 11:41:44 -0700 Subject: [PATCH 03/10] replace expect_error with expect_snapshot to log the message as well --- tests/testthat/test-arg_is_.R | 94 +++++++++++++++++------------------ 1 file changed, 47 insertions(+), 47 deletions(-) diff --git a/tests/testthat/test-arg_is_.R b/tests/testthat/test-arg_is_.R index 52a4a16db..c30fc2a78 100644 --- a/tests/testthat/test-arg_is_.R +++ b/tests/testthat/test-arg_is_.R @@ -20,10 +20,10 @@ test_that("logical", { expect_silent(arg_is_lgl(l)) expect_silent(arg_is_lgl(ll)) expect_silent(arg_is_lgl(l, ll)) - expect_error(arg_is_lgl(l, ll, n)) - expect_error(arg_is_lgl(x)) + expect_snapshot(error = TRUE, arg_is_lgl(l, ll, n)) + expect_snapshot(error = TRUE, arg_is_lgl(x)) expect_silent(arg_is_lgl(l, ll, n, allow_null = TRUE)) - expect_error(arg_is_lgl(l, ll, nn)) + expect_snapshot(error = TRUE, arg_is_lgl(l, ll, nn)) expect_silent(arg_is_lgl(l, ll, nn, allow_na = TRUE)) }) @@ -31,115 +31,115 @@ test_that("scalar", { expect_silent(arg_is_scalar(x)) expect_silent(arg_is_scalar(dd)) expect_silent(arg_is_scalar(x, y, dd)) - expect_error(arg_is_scalar(x, y, n)) + expect_snapshot(error = TRUE, arg_is_scalar(x, y, n)) expect_silent(arg_is_scalar(x, y, n, allow_null = TRUE)) - expect_error(arg_is_scalar(x, y, nn)) + expect_snapshot(error = TRUE, arg_is_scalar(x, y, nn)) expect_silent(arg_is_scalar(x, y, nn, allow_na = TRUE)) - expect_error(arg_is_scalar(v, nn)) - expect_error(arg_is_scalar(v, nn, allow_na = TRUE)) - expect_error(arg_is_scalar(v, n, allow_null = TRUE)) - expect_error(arg_is_scalar(nnn, allow_na = TRUE)) + expect_snapshot(error = TRUE, arg_is_scalar(v, nn)) + expect_snapshot(error = TRUE, arg_is_scalar(v, nn, allow_na = TRUE)) + expect_snapshot(error = TRUE, arg_is_scalar(v, n, allow_null = TRUE)) + expect_snapshot(error = TRUE, arg_is_scalar(nnn, allow_na = TRUE)) }) test_that("numeric", { expect_silent(arg_is_numeric(i, j, x, y)) - expect_error(arg_is_numeric(a)) + expect_snapshot(error = TRUE, arg_is_numeric(a)) expect_silent(arg_is_numeric(d)) expect_silent(arg_is_numeric(c(i, j))) expect_silent(arg_is_numeric(i, k)) expect_silent(arg_is_numeric(i, j, n, allow_null = TRUE)) - expect_error(arg_is_numeric(i, j, n)) - expect_error(arg_is_numeric(i, nn)) + expect_snapshot(error = TRUE, arg_is_numeric(i, j, n)) + expect_snapshot(error = TRUE, arg_is_numeric(i, nn)) expect_silent(arg_is_numeric(a = -10:10)) }) test_that("positive", { expect_silent(arg_is_pos(i, j, x, y)) - expect_error(arg_is_pos(a)) + expect_snapshot(error = TRUE, arg_is_pos(a)) expect_silent(arg_is_pos(d)) expect_silent(arg_is_pos(c(i, j))) - expect_error(arg_is_pos(i, k)) + expect_snapshot(error = TRUE, arg_is_pos(i, k)) expect_silent(arg_is_pos(i, j, n, allow_null = TRUE)) - expect_error(arg_is_pos(i, j, n)) - expect_error(arg_is_pos(i, nn)) - expect_error(arg_is_pos(a = 0:10)) + expect_snapshot(error = TRUE, arg_is_pos(i, j, n)) + expect_snapshot(error = TRUE, arg_is_pos(i, nn)) + expect_snapshot(error = TRUE, arg_is_pos(a = 0:10)) }) test_that("nonneg", { expect_silent(arg_is_nonneg(i, j, x, y)) - expect_error(arg_is_nonneg(a)) + expect_snapshot(error = TRUE, arg_is_nonneg(a)) expect_silent(arg_is_nonneg(d)) expect_silent(arg_is_nonneg(c(i, j))) - expect_error(arg_is_nonneg(i, k)) + expect_snapshot(error = TRUE, arg_is_nonneg(i, k)) expect_silent(arg_is_nonneg(i, j, n, allow_null = TRUE)) - expect_error(arg_is_nonneg(i, j, n)) - expect_error(arg_is_nonneg(i, nn)) + expect_snapshot(error = TRUE, arg_is_nonneg(i, j, n)) + expect_snapshot(error = TRUE, arg_is_nonneg(i, nn)) expect_silent(arg_is_nonneg(a = 0:10)) }) test_that("nonneg-int", { - expect_error(arg_is_nonneg_int(a)) - expect_error(arg_is_nonneg_int(d)) + expect_snapshot(error = TRUE, arg_is_nonneg_int(a)) + expect_snapshot(error = TRUE, arg_is_nonneg_int(d)) expect_silent(arg_is_nonneg_int(i, j)) expect_silent(arg_is_nonneg_int(c(i, j))) - expect_error(arg_is_nonneg_int(i, k)) + expect_snapshot(error = TRUE, arg_is_nonneg_int(i, k)) expect_silent(arg_is_nonneg_int(i, j, n, allow_null = TRUE)) - expect_error(arg_is_nonneg_int(i, j, n)) - expect_error(arg_is_nonneg_int(i, nn)) + expect_snapshot(error = TRUE, arg_is_nonneg_int(i, j, n)) + expect_snapshot(error = TRUE, arg_is_nonneg_int(i, nn)) expect_silent(arg_is_nonneg_int(a = 0:10)) }) test_that("date", { expect_silent(arg_is_date(d, dd)) expect_silent(arg_is_date(c(d, dd))) - expect_error(arg_is_date(d, dd, n)) - expect_error(arg_is_date(d, dd, nn)) + expect_snapshot(error = TRUE, arg_is_date(d, dd, n)) + expect_snapshot(error = TRUE, arg_is_date(d, dd, nn)) expect_silent(arg_is_date(d, dd, n, allow_null = TRUE)) # Upstream issue, see: https://github.com/mllg/checkmate/issues/256 # expect_silent(arg_is_date(d, dd, nn, allow_na = TRUE)) - expect_error(arg_is_date(a)) - expect_error(arg_is_date(v)) - expect_error(arg_is_date(ll)) + expect_snapshot(error = TRUE, arg_is_date(a)) + expect_snapshot(error = TRUE, arg_is_date(v)) + expect_snapshot(error = TRUE, arg_is_date(ll)) }) test_that("probabilities", { expect_silent(arg_is_probabilities(i, x)) - expect_error(arg_is_probabilities(a)) - expect_error(arg_is_probabilities(d)) + expect_snapshot(error = TRUE, arg_is_probabilities(a)) + expect_snapshot(error = TRUE, arg_is_probabilities(d)) expect_silent(arg_is_probabilities(c(.4, .7))) - expect_error(arg_is_probabilities(i, 1.1)) + expect_snapshot(error = TRUE, arg_is_probabilities(i, 1.1)) expect_silent(arg_is_probabilities(c(.4, .8), n, allow_null = TRUE)) - expect_error(arg_is_probabilities(c(.4, .8), n)) - expect_error(arg_is_probabilities(c(.4, .8), nn)) + expect_snapshot(error = TRUE, arg_is_probabilities(c(.4, .8), n)) + expect_snapshot(error = TRUE, arg_is_probabilities(c(.4, .8), nn)) }) test_that("chr", { expect_silent(arg_is_chr(a, b)) expect_silent(arg_is_chr(c(a, b))) - expect_error(arg_is_chr(a, b, n)) - expect_error(arg_is_chr(a, b, nn)) + expect_snapshot(error = TRUE, arg_is_chr(a, b, n)) + expect_snapshot(error = TRUE, arg_is_chr(a, b, nn)) expect_silent(arg_is_chr(a, b, n, allow_null = TRUE)) expect_silent(arg_is_chr(a, b, nn, allow_na = TRUE)) - expect_error(arg_is_chr(d)) - expect_error(arg_is_chr(v)) - expect_error(arg_is_chr(ll)) - expect_error(arg_is_chr(z = character(0))) + expect_snapshot(error = TRUE, arg_is_chr(d)) + expect_snapshot(error = TRUE, arg_is_chr(v)) + expect_snapshot(error = TRUE, arg_is_chr(ll)) + expect_snapshot(error = TRUE, arg_is_chr(z = character(0))) expect_silent(arg_is_chr(z = character(0), allow_empty = TRUE)) }) test_that("function", { expect_silent(arg_is_function(f, g, parsnip::linear_reg)) - expect_error(arg_is_function(c(a, b))) - expect_error(arg_is_function(c(f, g))) - expect_error(arg_is_function(f = NULL)) + expect_snapshot(error = TRUE, arg_is_function(c(a, b))) + expect_snapshot(error = TRUE, arg_is_function(c(f, g))) + expect_snapshot(error = TRUE, arg_is_function(f = NULL)) expect_silent(arg_is_function(g, f = NULL, allow_null = TRUE)) }) test_that("coerce scalar to date", { - expect_error(arg_to_date("12345")) + expect_snapshot(error = TRUE, arg_to_date("12345")) expect_s3_class(arg_to_date(12345), "Date") expect_s3_class(arg_to_date("2020-01-01"), "Date") - expect_error(arg_to_date(c("12345", "12345"))) + expect_snapshot(error = TRUE, arg_to_date(c("12345", "12345"))) }) From 0d1064a1399f89564d779c41f1a49bb9b6ea2007 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 19 Sep 2024 11:46:55 -0700 Subject: [PATCH 04/10] adjust imports and document --- NAMESPACE | 17 +++++++---------- R/epipredict-package.R | 7 +++---- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1a1d3af18..ea516dbde 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -214,18 +214,15 @@ import(distributional) import(epiprocess) import(parsnip) import(recipes) -importFrom(checkmate,assert) -importFrom(checkmate,assert_character) importFrom(checkmate,assert_class) -importFrom(checkmate,assert_date) -importFrom(checkmate,assert_function) -importFrom(checkmate,assert_int) -importFrom(checkmate,assert_integer) -importFrom(checkmate,assert_integerish) -importFrom(checkmate,assert_logical) -importFrom(checkmate,assert_number) importFrom(checkmate,assert_numeric) -importFrom(checkmate,assert_scalar) +importFrom(checkmate,test_character) +importFrom(checkmate,test_date) +importFrom(checkmate,test_function) +importFrom(checkmate,test_integerish) +importFrom(checkmate,test_logical) +importFrom(checkmate,test_numeric) +importFrom(checkmate,test_scalar) importFrom(cli,cli_abort) importFrom(cli,cli_warn) importFrom(dplyr,across) diff --git a/R/epipredict-package.R b/R/epipredict-package.R index 0aaf5f0c1..d473f6d9d 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,9 +1,8 @@ ## usethis namespace: start #' @import epiprocess parsnip -#' @importFrom checkmate assert assert_character assert_int assert_scalar -#' @importFrom checkmate assert_integerish assert_date assert_function -#' @importFrom checkmate assert_class assert_logical assert_numeric assert_number -#' @importFrom checkmate assert_integer +#' @importFrom checkmate assert_class assert_numeric +#' @importFrom checkmate test_scalar test_logical test_numeric test_integerish +#' @importFrom checkmate test_date test_character test_function #' @importFrom cli cli_abort cli_warn #' @importFrom dplyr relocate summarise summarize everything #' @importFrom dplyr filter mutate select left_join rename ungroup full_join From 96d5b9fabf352e5fa411acaabe735e05232d6dec Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 19 Sep 2024 12:11:34 -0700 Subject: [PATCH 05/10] create snapshot tests --- tests/testthat/_snaps/arg_is_.md | 376 +++++++++++++++++++++++++++++++ tests/testthat/test-arg_is_.R | 10 +- 2 files changed, 382 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/_snaps/arg_is_.md diff --git a/tests/testthat/_snaps/arg_is_.md b/tests/testthat/_snaps/arg_is_.md new file mode 100644 index 000000000..f75073767 --- /dev/null +++ b/tests/testthat/_snaps/arg_is_.md @@ -0,0 +1,376 @@ +# logical + + Code + arg_is_lgl(l, ll, n) + Condition + Error: + ! `n` must be of type . + +--- + + Code + arg_is_lgl(x) + Condition + Error: + ! `x` must be of type . + +--- + + Code + arg_is_lgl(l, ll, nn) + Condition + Error: + ! `nn` must be of type . + +# scalar + + Code + arg_is_scalar(x, y, n) + Condition + Error: + ! `n` must be a scalar. + +--- + + Code + arg_is_scalar(x, y, nn) + Condition + Error: + ! `nn` must be a scalar. + +--- + + Code + arg_is_scalar(v, nn) + Condition + Error: + ! `v` must be a scalar. + +--- + + Code + arg_is_scalar(v, nn, allow_na = TRUE) + Condition + Error: + ! `v` must be a scalar. + +--- + + Code + arg_is_scalar(v, n, allow_null = TRUE) + Condition + Error: + ! `v` must be a scalar. + +--- + + Code + arg_is_scalar(nnn, allow_na = TRUE) + Condition + Error: + ! `nnn` must be a scalar. + +# numeric + + Code + arg_is_numeric(a) + Condition + Error: + ! `a` must be of type . + +--- + + Code + arg_is_numeric(i, j, n) + Condition + Error: + ! `n` must be of type . + +--- + + Code + arg_is_numeric(i, nn) + Condition + Error: + ! `nn` must be of type . + +# positive + + Code + arg_is_pos(a) + Condition + Error: + ! `a` must be a strictly positive number. + +--- + + Code + arg_is_pos(i, k) + Condition + Error: + ! `k` must be strictly positive numbers. + +--- + + Code + arg_is_pos(i, j, n) + Condition + Error: + ! `n` must be strictly positive numbers. + +--- + + Code + arg_is_pos(i, nn) + Condition + Error: + ! `nn` must be a strictly positive number. + +--- + + Code + arg_is_pos(a = 0:10) + Condition + Error: + ! `0:10` must be strictly positive numbers. + +# nonneg + + Code + arg_is_nonneg(a) + Condition + Error: + ! `a` must be a non-negative number. + +--- + + Code + arg_is_nonneg(i, k) + Condition + Error: + ! `k` must be non-negative numbers. + +--- + + Code + arg_is_nonneg(i, j, n) + Condition + Error: + ! `n` must be non-negative numbers. + +--- + + Code + arg_is_nonneg(i, nn) + Condition + Error: + ! `nn` must be a non-negative number. + +# nonneg-int + + Code + arg_is_nonneg_int(a) + Condition + Error: + ! `a` must be a non-negative integer. + +--- + + Code + arg_is_nonneg_int(d) + Condition + Error: + ! `d` must be a non-negative integer. + +--- + + Code + arg_is_nonneg_int(i, k) + Condition + Error: + ! `k` must be non-negative integers. + +--- + + Code + arg_is_nonneg_int(i, j, n) + Condition + Error: + ! `n` must be non-negative integers. + +--- + + Code + arg_is_nonneg_int(i, nn) + Condition + Error: + ! `nn` must be a non-negative integer. + +# date + + Code + arg_is_date(d, dd, n) + Condition + Error: + ! `n` must be dates. + +--- + + Code + arg_is_date(d, dd, nn) + Condition + Error: + ! `nn` must be a date. + +--- + + Code + arg_is_date(a) + Condition + Error: + ! `a` must be a date. + +--- + + Code + arg_is_date(v) + Condition + Error: + ! `v` must be dates. + +--- + + Code + arg_is_date(ll) + Condition + Error: + ! `ll` must be dates. + +# probabilities + + Code + arg_is_probabilities(a) + Condition + Error: + ! `a` must lie in [0, 1]. + +--- + + Code + arg_is_probabilities(d) + Condition + Error: + ! `d` must lie in [0, 1]. + +--- + + Code + arg_is_probabilities(i, 1.1) + Condition + Error: + ! `1.1` must lie in [0, 1]. + +--- + + Code + arg_is_probabilities(c(0.4, 0.8), n) + Condition + Error: + ! `n` must lie in [0, 1]. + +--- + + Code + arg_is_probabilities(c(0.4, 0.8), nn) + Condition + Error: + ! `nn` must lie in [0, 1]. + +# chr + + Code + arg_is_chr(a, b, n) + Condition + Error: + ! `n` must be of type . + +--- + + Code + arg_is_chr(a, b, nn) + Condition + Error: + ! `nn` must be of type . + +--- + + Code + arg_is_chr(d) + Condition + Error: + ! `d` must be of type . + +--- + + Code + arg_is_chr(v) + Condition + Error: + ! `v` must be of type . + +--- + + Code + arg_is_chr(ll) + Condition + Error: + ! `ll` must be of type . + +--- + + Code + arg_is_chr(z) + Condition + Error: + ! `z` must be of type . + +# function + + Code + arg_is_function(c(a, b)) + Condition + Error: + ! `c(a, b)` must be of type . + +--- + + Code + arg_is_function(c(f, g)) + Condition + Error: + ! `c(f, g)` must be of type . + +--- + + Code + arg_is_function(f) + Condition + Error: + ! `f` must be of type . + +# coerce scalar to date + + Code + arg_to_date("12345") + Condition + Error in `arg_to_date()`: + ! `x` must be a date. + +--- + + Code + arg_to_date(c("12345", "12345")) + Condition + Error in `arg_to_date()`: + ! `x` must be a scalar. + diff --git a/tests/testthat/test-arg_is_.R b/tests/testthat/test-arg_is_.R index c30fc2a78..84d4ef4cb 100644 --- a/tests/testthat/test-arg_is_.R +++ b/tests/testthat/test-arg_is_.R @@ -125,16 +125,18 @@ test_that("chr", { expect_snapshot(error = TRUE, arg_is_chr(d)) expect_snapshot(error = TRUE, arg_is_chr(v)) expect_snapshot(error = TRUE, arg_is_chr(ll)) - expect_snapshot(error = TRUE, arg_is_chr(z = character(0))) - expect_silent(arg_is_chr(z = character(0), allow_empty = TRUE)) + z <- character(0) + expect_snapshot(error = TRUE, arg_is_chr(z)) + expect_silent(arg_is_chr(z, allow_empty = TRUE)) }) test_that("function", { expect_silent(arg_is_function(f, g, parsnip::linear_reg)) expect_snapshot(error = TRUE, arg_is_function(c(a, b))) expect_snapshot(error = TRUE, arg_is_function(c(f, g))) - expect_snapshot(error = TRUE, arg_is_function(f = NULL)) - expect_silent(arg_is_function(g, f = NULL, allow_null = TRUE)) + f <- NULL + expect_snapshot(error = TRUE, arg_is_function(f)) + expect_silent(arg_is_function(g, f, allow_null = TRUE)) }) test_that("coerce scalar to date", { From 1822985937b61115a8f95cba6c453e74bdc9f0c2 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 19 Sep 2024 12:16:56 -0700 Subject: [PATCH 06/10] news, bump version, run styler --- DESCRIPTION | 2 +- NEWS.md | 1 + R/utils-arg.R | 36 ++++++++++++++++++++++++------------ 3 files changed, 26 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index bccba8ece..1f0c22611 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: epipredict Title: Basic epidemiology forecasting methods -Version: 0.0.20 +Version: 0.0.21 Authors@R: c( person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 15aa6de29..e64638bc4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -57,3 +57,4 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.0.x will indicat - Add `step_epi_slide` to produce generic sliding computations over an `epi_df` - Add quantile random forests (via `{grf}`) as a parsnip engine - Replace `epi_keys()` with `epiprocess::key_colnames()`, #352 +- More descriptive error messages from `arg_is_*()`, #287 diff --git a/R/utils-arg.R b/R/utils-arg.R index 174d016d8..081d153fb 100644 --- a/R/utils-arg.R +++ b/R/utils-arg.R @@ -23,8 +23,10 @@ arg_is_scalar <- function(..., allow_null = FALSE, allow_na = FALSE, arg_is_lgl <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - ok <- test_logical(value, null.ok = allow_null, any.missing = allow_na, - min.len = as.integer(!allow_empty)) + ok <- test_logical(value, + null.ok = allow_null, any.missing = allow_na, + min.len = as.integer(!allow_empty) + ) if (!ok) { cli_abort("{.arg {name}} must be of type {.cls logical}.", call = call) } @@ -34,8 +36,10 @@ arg_is_lgl <- function(..., allow_null = FALSE, allow_na = FALSE, arg_is_lgl_scalar <- function(..., allow_null = FALSE, allow_na = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - ok <- test_logical(value, null.ok = allow_null, any.missing = allow_na, - min.len = 1, max.len = 1) + ok <- test_logical(value, + null.ok = allow_null, any.missing = allow_na, + min.len = 1, max.len = 1 + ) if (!ok) { cli_abort( "{.arg {name}} must be a scalar of type {.cls logical}.", @@ -57,7 +61,8 @@ arg_is_numeric <- function(..., allow_null = FALSE, call = caller_env()) { arg_is_pos <- function(..., allow_null = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { ok <- test_numeric( - value, lower = .Machine$double.eps, + value, + lower = .Machine$double.eps, null.ok = allow_null, any.missing = FALSE ) if (!ok) { @@ -138,8 +143,10 @@ arg_is_date <- function(..., allow_null = FALSE, call = caller_env()) { arg_is_probabilities <- function(..., allow_null = FALSE, allow_na = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - ok <- test_numeric(value, lower = 0, upper = 1, null.ok = allow_null, - any.missing = allow_na) + ok <- test_numeric(value, + lower = 0, upper = 1, null.ok = allow_null, + any.missing = allow_na + ) if (!ok) { cli_abort("{.arg {name}} must lie in [0, 1].", call = call) } @@ -149,8 +156,10 @@ arg_is_probabilities <- function(..., allow_null = FALSE, allow_na = FALSE, arg_is_chr <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - ok <- test_character(value, null.ok = allow_null, any.missing = allow_na, - min.len = as.integer(!allow_empty)) + ok <- test_character(value, + null.ok = allow_null, any.missing = allow_na, + min.len = as.integer(!allow_empty) + ) if (!ok) { cli_abort("{.arg {name}} must be of type {.cls character}.", call = call) } @@ -160,12 +169,15 @@ arg_is_chr <- function(..., allow_null = FALSE, allow_na = FALSE, allow_empty = arg_is_chr_scalar <- function(..., allow_null = FALSE, allow_na = FALSE, call = caller_env()) { handle_arg_list(..., .tests = function(name, value) { - ok <- test_character(value, null.ok = allow_null, any.missing = allow_na, - len = 1L) + ok <- test_character(value, + null.ok = allow_null, any.missing = allow_na, + len = 1L + ) if (!ok) { cli_abort( "{.arg {name}} must be a scalar of type {.cls character}.", - call = call) + call = call + ) } }) } From 37d2352446142b55ba0b79590d8a104de8ed0e6e Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 12:34:16 -0700 Subject: [PATCH 07/10] test: snapshot step_* errors --- tests/testthat/_snaps/arg_is_.md | 8 +++++ tests/testthat/test-arg_is_.R | 9 +++++- tests/testthat/test-step_epi_naomit.R | 2 +- tests/testthat/test-step_epi_shift.R | 13 ++++---- tests/testthat/test-step_epi_slide.R | 36 +++++++++++------------ tests/testthat/test-step_growth_rate.R | 30 +++++++++---------- tests/testthat/test-step_lag_difference.R | 18 ++++++------ 7 files changed, 66 insertions(+), 50 deletions(-) diff --git a/tests/testthat/_snaps/arg_is_.md b/tests/testthat/_snaps/arg_is_.md index f75073767..fcb823f2a 100644 --- a/tests/testthat/_snaps/arg_is_.md +++ b/tests/testthat/_snaps/arg_is_.md @@ -374,3 +374,11 @@ Error in `arg_to_date()`: ! `x` must be a scalar. +# simple surface step test + + Code + epi_recipe(jhu_csse_daily_subset) %>% step_epi_lag(death_rate, lag = "hello") + Condition + Error in `step_epi_lag()`: + ! `lag` must be a non-negative integer. + diff --git a/tests/testthat/test-arg_is_.R b/tests/testthat/test-arg_is_.R index 84d4ef4cb..89c2c936f 100644 --- a/tests/testthat/test-arg_is_.R +++ b/tests/testthat/test-arg_is_.R @@ -15,6 +15,7 @@ dd <- Sys.Date() - 5 v <- 1:5 l <- TRUE ll <- c(TRUE, FALSE) +z <- character(0) test_that("logical", { expect_silent(arg_is_lgl(l)) @@ -125,7 +126,6 @@ test_that("chr", { expect_snapshot(error = TRUE, arg_is_chr(d)) expect_snapshot(error = TRUE, arg_is_chr(v)) expect_snapshot(error = TRUE, arg_is_chr(ll)) - z <- character(0) expect_snapshot(error = TRUE, arg_is_chr(z)) expect_silent(arg_is_chr(z, allow_empty = TRUE)) }) @@ -145,3 +145,10 @@ test_that("coerce scalar to date", { expect_s3_class(arg_to_date("2020-01-01"), "Date") expect_snapshot(error = TRUE, arg_to_date(c("12345", "12345"))) }) + +test_that("simple surface step test", { + expect_snapshot( + error = TRUE, + epi_recipe(jhu_csse_daily_subset) %>% step_epi_lag(death_rate, lag = "hello") + ) +}) diff --git a/tests/testthat/test-step_epi_naomit.R b/tests/testthat/test-step_epi_naomit.R index 2fb173f01..0e5e1750f 100644 --- a/tests/testthat/test-step_epi_naomit.R +++ b/tests/testthat/test-step_epi_naomit.R @@ -17,7 +17,7 @@ r <- epi_recipe(x) %>% step_epi_lag(death_rate, lag = c(0, 7, 14)) test_that("Argument must be a recipe", { - expect_error(step_epi_naomit(x)) + expect_snapshot(error = TRUE, step_epi_naomit(x)) }) z1 <- step_epi_naomit(r) diff --git a/tests/testthat/test-step_epi_shift.R b/tests/testthat/test-step_epi_shift.R index da04fd0f2..1f83120b3 100644 --- a/tests/testthat/test-step_epi_shift.R +++ b/tests/testthat/test-step_epi_shift.R @@ -20,7 +20,8 @@ slm_fit <- function(recipe, data = x) { } test_that("Values for ahead and lag must be integer values", { - expect_error( + expect_snapshot( + error = TRUE, r1 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = 3.6) %>% step_epi_lag(death_rate, lag = 1.9) @@ -28,7 +29,8 @@ test_that("Values for ahead and lag must be integer values", { }) test_that("A negative lag value should should throw an error", { - expect_error( + expect_snapshot( + error = TRUE, r2 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = 7) %>% step_epi_lag(death_rate, lag = -7) @@ -36,7 +38,8 @@ test_that("A negative lag value should should throw an error", { }) test_that("A nonpositive ahead value should throw an error", { - expect_error( + expect_snapshot( + error = TRUE, r3 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = -7) %>% step_epi_lag(death_rate, lag = 7) @@ -48,9 +51,7 @@ test_that("Values for ahead and lag cannot be duplicates", { step_epi_ahead(death_rate, ahead = 7) %>% step_epi_lag(death_rate, lag = 7) %>% step_epi_lag(death_rate, lag = 7) - expect_error( - slm_fit(r4) - ) + expect_snapshot(error = TRUE, slm_fit(r4)) }) test_that("Check that epi_lag shifts applies the shift", { diff --git a/tests/testthat/test-step_epi_slide.R b/tests/testthat/test-step_epi_slide.R index 29e046eae..5130d1eb3 100644 --- a/tests/testthat/test-step_epi_slide.R +++ b/tests/testthat/test-step_epi_slide.R @@ -21,25 +21,25 @@ rolled_after <- edf %>% test_that("epi_slide errors when needed", { # not an epi_recipe - expect_error(recipe(edf) %>% step_epi_slide(value, .f = mean, before = 6L)) + expect_snapshot(error = TRUE, recipe(edf) %>% step_epi_slide(value, .f = mean, before = 6L)) # non-scalar args - expect_error(r %>% step_epi_slide(value, .f = mean, before = c(3L, 6L))) - expect_error(r %>% step_epi_slide(value, .f = mean, after = c(3L, 6L))) - expect_error(r %>% step_epi_slide(value, .f = mean, skip = c(TRUE, FALSE))) - expect_error(r %>% step_epi_slide(value, .f = mean, role = letters[1:2])) - expect_error(r %>% step_epi_slide(value, .f = mean, prefix = letters[1:2])) - expect_error(r %>% step_epi_slide(value, .f = mean, id = letters[1:2])) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = c(3L, 6L))) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, after = c(3L, 6L))) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, skip = c(TRUE, FALSE))) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, role = letters[1:2])) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, prefix = letters[1:2])) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, id = letters[1:2])) # wrong types - expect_error(r %>% step_epi_slide(value, .f = mean, before = 1.5)) - expect_error(r %>% step_epi_slide(value, .f = mean, after = 1.5)) - expect_error(r %>% step_epi_slide(value, .f = mean, skip = "a")) - expect_error(r %>% step_epi_slide(value, .f = mean, role = 1)) - expect_error(r %>% step_epi_slide(value, .f = mean, prefix = 1)) - expect_error(r %>% step_epi_slide(value, .f = mean, id = 1)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1.5)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1.5)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, skip = "a")) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, role = 1)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, prefix = 1)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, before = 1L, after = 1L, id = 1)) # function problems - expect_error(r %>% step_epi_slide(value)) - expect_error(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)) }) @@ -53,10 +53,10 @@ test_that("epi_slide handles different function specs", { prep(edf) %>% bake(new_data = NULL) # formula NOT currently supported - expect_error( + expect_snapshot( + error = TRUE, lfun <- r %>% - step_epi_slide(value, .f = ~ mean(.x, na.rm = TRUE), before = 3L), - regexp = "cannot be a formula." + step_epi_slide(value, .f = ~ mean(.x, na.rm = TRUE), before = 3L) ) blfun <- r %>% step_epi_slide(value, .f = function(x) mean(x, na.rm = TRUE), before = 3L) %>% diff --git a/tests/testthat/test-step_growth_rate.R b/tests/testthat/test-step_growth_rate.R index 29a2fc2f5..f2845d812 100644 --- a/tests/testthat/test-step_growth_rate.R +++ b/tests/testthat/test-step_growth_rate.R @@ -1,25 +1,25 @@ test_that("step_growth_rate validates arguments", { df <- data.frame(time_value = 1:5, geo_value = rep("a", 5), value = 6:10) r <- recipes::recipe(df) - expect_error(step_growth_rate(r)) + expect_snapshot(error = TRUE, step_growth_rate(r)) edf <- as_epi_df(df) r <- epi_recipe(edf) - expect_error(step_growth_rate(r, value, role = 1)) - expect_error(step_growth_rate(r, value, method = "abc")) - expect_error(step_growth_rate(r, value, horizon = 0)) - expect_error(step_growth_rate(r, value, horizon = c(1, 2))) - expect_error(step_growth_rate(r, value, prefix = letters[1:2])) - expect_error(step_growth_rate(r, value, id = letters[1:2])) - expect_error(step_growth_rate(r, value, prefix = letters[1:2])) - expect_error(step_growth_rate(r, value, prefix = 1)) - expect_error(step_growth_rate(r, value, id = 1)) - expect_error(step_growth_rate(r, value, log_scale = 1)) - expect_error(step_growth_rate(r, value, skip = 1)) - expect_error(step_growth_rate(r, value, additional_gr_args_list = 1:5)) - expect_error(step_growth_rate(r, value, replace_Inf = "c")) - expect_error(step_growth_rate(r, value, replace_Inf = c(1, 2))) + expect_snapshot(error = TRUE, step_growth_rate(r, value, role = 1)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, method = "abc")) + expect_snapshot(error = TRUE, step_growth_rate(r, value, horizon = 0)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, horizon = c(1, 2))) + expect_snapshot(error = TRUE, step_growth_rate(r, value, prefix = letters[1:2])) + expect_snapshot(error = TRUE, step_growth_rate(r, value, id = letters[1:2])) + expect_snapshot(error = TRUE, step_growth_rate(r, value, prefix = letters[1:2])) + expect_snapshot(error = TRUE, step_growth_rate(r, value, prefix = 1)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, id = 1)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, log_scale = 1)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, skip = 1)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, additional_gr_args_list = 1:5)) + expect_snapshot(error = TRUE, step_growth_rate(r, value, replace_Inf = "c")) + expect_snapshot(error = TRUE, step_growth_rate(r, value, replace_Inf = c(1, 2))) expect_silent(step_growth_rate(r, value, replace_Inf = NULL)) expect_silent(step_growth_rate(r, value, replace_Inf = NA)) }) diff --git a/tests/testthat/test-step_lag_difference.R b/tests/testthat/test-step_lag_difference.R index cd92da1fb..6ff9884a7 100644 --- a/tests/testthat/test-step_lag_difference.R +++ b/tests/testthat/test-step_lag_difference.R @@ -1,20 +1,20 @@ test_that("step_lag_difference validates arguments", { df <- data.frame(time_value = 1:5, geo_value = rep("a", 5), value = 6:10) r <- recipes::recipe(df) - expect_error(step_lag_difference(r)) + expect_snapshot(error = TRUE, step_lag_difference(r)) edf <- as_epi_df(df) r <- epi_recipe(edf) - expect_error(step_lag_difference(r, value, role = 1)) - expect_error(step_lag_difference(r, value, horizon = 0)) + expect_snapshot(error = TRUE, step_lag_difference(r, value, role = 1)) + expect_snapshot(error = TRUE, step_lag_difference(r, value, horizon = 0)) expect_silent(step_lag_difference(r, value, horizon = c(1, 2))) - expect_error(step_lag_difference(r, value, prefix = letters[1:2])) - expect_error(step_lag_difference(r, value, id = letters[1:2])) - expect_error(step_lag_difference(r, value, prefix = letters[1:2])) - expect_error(step_lag_difference(r, value, prefix = 1)) - expect_error(step_lag_difference(r, value, id = 1)) - expect_error(step_lag_difference(r, value, skip = 1)) + expect_snapshot(error = TRUE, step_lag_difference(r, value, prefix = letters[1:2])) + expect_snapshot(error = TRUE, step_lag_difference(r, value, id = letters[1:2])) + expect_snapshot(error = TRUE, step_lag_difference(r, value, prefix = letters[1:2])) + expect_snapshot(error = TRUE, step_lag_difference(r, value, prefix = 1)) + expect_snapshot(error = TRUE, step_lag_difference(r, value, id = 1)) + expect_snapshot(error = TRUE, step_lag_difference(r, value, skip = 1)) }) From 78fbaa0aed72b5142ab479c67b40cd58d84d8652 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 12:41:35 -0700 Subject: [PATCH 08/10] repo: bump version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7819a08d2..b7bb35de9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: epipredict Title: Basic epidemiology forecasting methods -Version: 0.0.21 +Version: 0.0.22 Authors@R: c( person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"), From 65385e2ee2e7fa56a5f7314cae4d422a2691b258 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 12:46:42 -0700 Subject: [PATCH 09/10] test: add new snapshots --- tests/testthat/_snaps/step_epi_naomit.md | 8 ++ tests/testthat/_snaps/step_epi_shift.md | 36 ++++++ tests/testthat/_snaps/step_epi_slide.md | 129 +++++++++++++++++++ tests/testthat/_snaps/step_growth_rate.md | 121 +++++++++++++++++ tests/testthat/_snaps/step_lag_difference.md | 72 +++++++++++ 5 files changed, 366 insertions(+) create mode 100644 tests/testthat/_snaps/step_epi_naomit.md create mode 100644 tests/testthat/_snaps/step_epi_shift.md create mode 100644 tests/testthat/_snaps/step_epi_slide.md create mode 100644 tests/testthat/_snaps/step_growth_rate.md create mode 100644 tests/testthat/_snaps/step_lag_difference.md diff --git a/tests/testthat/_snaps/step_epi_naomit.md b/tests/testthat/_snaps/step_epi_naomit.md new file mode 100644 index 000000000..653e84d0e --- /dev/null +++ b/tests/testthat/_snaps/step_epi_naomit.md @@ -0,0 +1,8 @@ +# Argument must be a recipe + + Code + step_epi_naomit(x) + Condition + Error in `step_epi_naomit()`: + ! inherits(recipe, "recipe") is not TRUE + diff --git a/tests/testthat/_snaps/step_epi_shift.md b/tests/testthat/_snaps/step_epi_shift.md new file mode 100644 index 000000000..44c828118 --- /dev/null +++ b/tests/testthat/_snaps/step_epi_shift.md @@ -0,0 +1,36 @@ +# Values for ahead and lag must be integer values + + Code + r1 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = 3.6) %>% + step_epi_lag(death_rate, lag = 1.9) + Condition + Error in `step_epi_ahead()`: + ! `ahead` must be a non-negative integer. + +# A negative lag value should should throw an error + + Code + r2 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = 7) %>% step_epi_lag( + death_rate, lag = -7) + Condition + Error in `step_epi_lag()`: + ! `lag` must be a non-negative integer. + +# A nonpositive ahead value should throw an error + + Code + r3 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = -7) %>% step_epi_lag( + death_rate, lag = 7) + Condition + Error in `step_epi_ahead()`: + ! `ahead` must be a non-negative integer. + +# Values for ahead and lag cannot be duplicates + + Code + slm_fit(r4) + Condition + Error in `bake()`: + ! Name collision occured in + The following variable name already exists: "lag_7_death_rate". + diff --git a/tests/testthat/_snaps/step_epi_slide.md b/tests/testthat/_snaps/step_epi_slide.md new file mode 100644 index 000000000..27ca908b7 --- /dev/null +++ b/tests/testthat/_snaps/step_epi_slide.md @@ -0,0 +1,129 @@ +# epi_slide errors when needed + + Code + recipe(edf) %>% step_epi_slide(value, .f = mean, .window_size = 7L) + Condition + Error in `step_epi_slide()`: + ! This recipe step can only operate on an . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = c(3L, 6L)) + Condition + Error in `epiprocess:::validate_slide_window_arg()`: + ! Slide function expected `.window_size` to be a non-null, scalar integer >= 1. + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .align = c("right", "left")) + Condition + Error in `step_epi_slide()`: + ! step_epi_slide: `.window_size` must be specified. + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, skip = c(TRUE, FALSE)) + Condition + Error in `step_epi_slide()`: + ! `skip` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, role = letters[1:2]) + Condition + Error in `step_epi_slide()`: + ! `role` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, prefix = letters[1:2]) + Condition + Error in `step_epi_slide()`: + ! `prefix` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, id = letters[1:2]) + Condition + Error in `step_epi_slide()`: + ! `id` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1.5) + Condition + Error in `epiprocess:::validate_slide_window_arg()`: + ! Slide function expected `.window_size` to be a difftime with units in days or non-negative integer or Inf. + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, .align = 1.5) + Condition + Error in `step_epi_slide()`: + ! `.align` must be a character vector, not the number 1.5. + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, skip = "a") + Condition + Error in `step_epi_slide()`: + ! `skip` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, role = 1) + Condition + Error in `step_epi_slide()`: + ! `role` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, prefix = 1) + Condition + Error in `step_epi_slide()`: + ! `prefix` must be a scalar of type . + +--- + + Code + r %>% step_epi_slide(value, .f = mean, .window_size = 1L, id = 1) + Condition + Error in `step_epi_slide()`: + ! `id` must be a scalar of type . + +--- + + 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 + lfun <- r %>% step_epi_slide(value, .f = ~ mean(.x, na.rm = TRUE), + .window_size = 4L) + Condition + Error in `validate_slide_fun()`: + ! In, `step_epi_slide()`, `.f` cannot be a formula. + diff --git a/tests/testthat/_snaps/step_growth_rate.md b/tests/testthat/_snaps/step_growth_rate.md new file mode 100644 index 000000000..5a3ac6f44 --- /dev/null +++ b/tests/testthat/_snaps/step_growth_rate.md @@ -0,0 +1,121 @@ +# step_growth_rate validates arguments + + Code + step_growth_rate(r) + Condition + Error in `step_growth_rate()`: + ! This recipe step can only operate on an . + +--- + + Code + step_growth_rate(r, value, role = 1) + Condition + Error in `step_growth_rate()`: + ! `role` must be of type . + +--- + + Code + step_growth_rate(r, value, method = "abc") + Condition + Error in `step_growth_rate()`: + ! `method` must be one of "rel_change" or "linear_reg", not "abc". + +--- + + Code + step_growth_rate(r, value, horizon = 0) + Condition + Error in `step_growth_rate()`: + ! `horizon` must be a positive integer. + +--- + + Code + step_growth_rate(r, value, horizon = c(1, 2)) + Condition + Error in `step_growth_rate()`: + ! `horizon` must be a scalar. + +--- + + Code + step_growth_rate(r, value, prefix = letters[1:2]) + Condition + Error in `step_growth_rate()`: + ! `prefix` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, id = letters[1:2]) + Condition + Error in `step_growth_rate()`: + ! `id` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, prefix = letters[1:2]) + Condition + Error in `step_growth_rate()`: + ! `prefix` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, prefix = 1) + Condition + Error in `step_growth_rate()`: + ! `prefix` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, id = 1) + Condition + Error in `step_growth_rate()`: + ! `id` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, log_scale = 1) + Condition + Error in `step_growth_rate()`: + ! `log_scale` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, skip = 1) + Condition + Error in `step_growth_rate()`: + ! `skip` must be a scalar of type . + +--- + + Code + step_growth_rate(r, value, additional_gr_args_list = 1:5) + Condition + Error in `step_growth_rate()`: + ! `additional_gr_args_list` must be a . + i See `?epiprocess::growth_rate` for available options. + +--- + + Code + step_growth_rate(r, value, replace_Inf = "c") + Condition + Error in `step_growth_rate()`: + ! `replace_Inf` must be of type . + +--- + + Code + step_growth_rate(r, value, replace_Inf = c(1, 2)) + Condition + Error in `step_growth_rate()`: + ! replace_Inf must be a scalar. + diff --git a/tests/testthat/_snaps/step_lag_difference.md b/tests/testthat/_snaps/step_lag_difference.md new file mode 100644 index 000000000..4edc9c287 --- /dev/null +++ b/tests/testthat/_snaps/step_lag_difference.md @@ -0,0 +1,72 @@ +# step_lag_difference validates arguments + + Code + step_lag_difference(r) + Condition + Error in `step_lag_difference()`: + ! This recipe step can only operate on an . + +--- + + Code + step_lag_difference(r, value, role = 1) + Condition + Error in `step_lag_difference()`: + ! `role` must be of type . + +--- + + Code + step_lag_difference(r, value, horizon = 0) + Condition + Error in `step_lag_difference()`: + ! `horizon` must be a positive integer. + +--- + + Code + step_lag_difference(r, value, prefix = letters[1:2]) + Condition + Error in `step_lag_difference()`: + ! `prefix` must be a scalar of type . + +--- + + Code + step_lag_difference(r, value, id = letters[1:2]) + Condition + Error in `step_lag_difference()`: + ! `id` must be a scalar of type . + +--- + + Code + step_lag_difference(r, value, prefix = letters[1:2]) + Condition + Error in `step_lag_difference()`: + ! `prefix` must be a scalar of type . + +--- + + Code + step_lag_difference(r, value, prefix = 1) + Condition + Error in `step_lag_difference()`: + ! `prefix` must be a scalar of type . + +--- + + Code + step_lag_difference(r, value, id = 1) + Condition + Error in `step_lag_difference()`: + ! `id` must be a scalar of type . + +--- + + Code + step_lag_difference(r, value, skip = 1) + Condition + Error in `step_lag_difference()`: + ! `skip` must be a scalar of type . + From 434262ab56727fbb3f5a2d4e73ec40f6d1e1b5ef Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 13:33:20 -0700 Subject: [PATCH 10/10] repo: bump version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index c0e9e7656..26093014c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: epipredict Title: Basic epidemiology forecasting methods -Version: 0.0.23 +Version: 0.0.24 Authors@R: c( person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"),