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 - }