From dd9c92e3985dd9fa23826a4d65e26d15d9a582a0 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Wed, 11 Sep 2024 13:49:15 -0700 Subject: [PATCH 01/37] fix and add test --- R/epi_workflow.R | 4 ++- tests/testthat/_snaps/epi_workflow.md | 12 +++++++++ tests/testthat/test-epi_workflow.R | 37 +++++++++++++++++++++++++++ 3 files changed, 52 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/_snaps/epi_workflow.md diff --git a/R/epi_workflow.R b/R/epi_workflow.R index b059a81d0..58b8bafeb 100644 --- a/R/epi_workflow.R +++ b/R/epi_workflow.R @@ -102,7 +102,9 @@ fit.epi_workflow <- function(object, data, ..., control = workflows::control_wor ) object$original_data <- data - NextMethod() + res <- NextMethod() + class(res) <- c("epi_workflow", class(res)) + res } #' Predict from an epi_workflow diff --git a/tests/testthat/_snaps/epi_workflow.md b/tests/testthat/_snaps/epi_workflow.md new file mode 100644 index 000000000..abd57da2f --- /dev/null +++ b/tests/testthat/_snaps/epi_workflow.md @@ -0,0 +1,12 @@ +# fit method does not silently drop the class + + epi_recipe has been called with a non-epi_df object, returning a regular recipe. Various step_epi_* functions will not work. + +--- + + Code + ewf_erec_edf %>% fit(tbl) + Condition + Error in `if (new_meta != old_meta) ...`: + ! argument is of length zero + diff --git a/tests/testthat/test-epi_workflow.R b/tests/testthat/test-epi_workflow.R index 09dd6fe82..8236a5885 100644 --- a/tests/testthat/test-epi_workflow.R +++ b/tests/testthat/test-epi_workflow.R @@ -105,3 +105,40 @@ test_that("forecast method errors when workflow not fit", { expect_error(forecast(wf)) }) + +test_that("fit method does not silently drop the class", { + # This is issue #363 + + library(recipes) + tbl <- tibble::tibble( + geo_value = 1, + time_value = 1:100, + x = 1:100, + y = x + rnorm(100L) + ) + edf <- as_epi_df(tbl) + + rec_tbl <- recipe(y ~ x, data = tbl) + rec_edf <- recipe(y ~ x, data = edf) + expect_snapshot_warning(erec_tbl <- epi_recipe(y ~ x, data = tbl)) + erec_edf <- epi_recipe(y ~ x, data = edf) + + ewf_rec_tbl <- epi_workflow(rec_tbl, linear_reg()) + ewf_rec_edf <- epi_workflow(rec_edf, linear_reg()) + ewf_erec_edf <- epi_workflow(erec_edf, linear_reg()) + + # above are all epi_workflows: + + expect_s3_class(ewf_rec_tbl, "epi_workflow") + expect_s3_class(ewf_rec_edf, "epi_workflow") + expect_s3_class(ewf_erec_edf, "epi_workflow") + + # but fitting drops the class or generates errors in many cases: + + expect_s3_class(ewf_rec_tbl %>% fit(tbl), "epi_workflow") + expect_s3_class(ewf_rec_tbl %>% fit(edf), "epi_workflow") + expect_s3_class(ewf_rec_edf %>% fit(tbl), "epi_workflow") + expect_s3_class(ewf_rec_edf %>% fit(edf), "epi_workflow") + expect_snapshot(ewf_erec_edf %>% fit(tbl), error = TRUE) + expect_s3_class(ewf_erec_edf %>% fit(edf), "epi_workflow") +}) From 9b47549864ca6e7132e09636a28a23df6b73265d Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Wed, 11 Sep 2024 13:56:27 -0700 Subject: [PATCH 02/37] bump version, news --- DESCRIPTION | 2 +- NEWS.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6d1217587..7bdc31a6e 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..ecdf9efe6 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 +- Fix bug where `fit()` drops the `epi_workflow` class, #363 From fbceb88e9fd3307529ec5fff3ec0886592cc37c7 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 12 Sep 2024 15:33:59 -0700 Subject: [PATCH 03/37] try to retain the class to the extent possible --- R/epi_recipe.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/epi_recipe.R b/R/epi_recipe.R index 88ba605cd..22ecb0a31 100644 --- a/R/epi_recipe.R +++ b/R/epi_recipe.R @@ -63,6 +63,7 @@ epi_recipe.default <- function(x, ...) { #' r epi_recipe.epi_df <- function(x, formula = NULL, ..., vars = NULL, roles = NULL) { + attr(x, "decay_to_tibble") <- FALSE if (!is.null(formula)) { if (!is.null(vars)) { rlang::abort( @@ -160,6 +161,7 @@ epi_recipe.formula <- function(formula, data, ...) { return(recipes::recipe(formula, data, ...)) } + attr(data, "decay_to_tibble") <- FALSE f_funcs <- recipes:::fun_calls(formula, data) if (any(f_funcs == "-")) { abort("`-` is not allowed in a recipe formula. Use `step_rm()` instead.") From 9cf5b8507f01397388c84d6598232aaad3f3aa8f Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Thu, 12 Sep 2024 15:36:25 -0700 Subject: [PATCH 04/37] bump version --- DESCRIPTION | 4 ++-- NEWS.md | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6d1217587..a59c38327 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"), @@ -23,7 +23,7 @@ URL: https://github.com/cmu-delphi/epipredict/, https://cmu-delphi.github.io/epipredict BugReports: https://github.com/cmu-delphi/epipredict/issues/ Depends: - epiprocess (>= 0.7.5), + epiprocess (>= 0.7.12), parsnip (>= 1.0.0), R (>= 3.5.0) Imports: diff --git a/NEWS.md b/NEWS.md index 15aa6de29..5d1082c2b 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 +- Try to retain the `epi_df` class during baking to the extent possible, #376 From 4d8a24dd45735ae77ba754af169ede46b0e41fa0 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Fri, 13 Sep 2024 15:47:00 -0700 Subject: [PATCH 05/37] 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 06/37] 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 07/37] 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 08/37] 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 09/37] 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 10/37] 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 f7fec68c00432fa96f3d7691a1b7e55db6a02ff5 Mon Sep 17 00:00:00 2001 From: dsweber2 Date: Wed, 25 Sep 2024 11:57:48 -0500 Subject: [PATCH 11/37] make internal versioning accurate --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6d1217587..a7df5ba5a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,8 @@ URL: https://github.com/cmu-delphi/epipredict/, https://cmu-delphi.github.io/epipredict BugReports: https://github.com/cmu-delphi/epipredict/issues/ Depends: - epiprocess (>= 0.7.5), + epiprocess (>= 0.8.0), + epiprocess (< 0.9.0), parsnip (>= 1.0.0), R (>= 3.5.0) Imports: From acaca4fd6b72a0a26c91ec1cccf9a31eefc4f3e9 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Fri, 27 Sep 2024 09:33:12 -0700 Subject: [PATCH 12/37] add missing topic --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index c6df4c82d..468da62ac 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -76,6 +76,7 @@ reference: contents: - quantile_reg - smooth_quantile_reg + - grf_quantiles - title: Custom panel data forecasting workflows contents: - epi_recipe From 0e7d90f072a6770c209f53d9bcf5ee5b2aef4720 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Wed, 25 Sep 2024 19:01:42 -0700 Subject: [PATCH 13/37] fix: update for compatibility with epiprocess==0.9.0 Co-authored-by: Daniel McDonald --- .Rbuildignore | 3 +- DESCRIPTION | 5 +- R/autoplot.R | 2 +- R/cdc_baseline_forecaster.R | 6 +- R/epi_recipe.R | 12 +- R/epi_workflow.R | 3 +- R/flusight_hub_formatter.R | 4 +- R/key_colnames.R | 15 ++- R/step_epi_slide.R | 121 +++++++++--------- R/utils-misc.R | 16 +-- data-raw/grad_employ_subset.R | 2 +- data/grad_employ_subset.rda | Bin 8491 -> 9546 bytes man/autoplot-epipred.Rd | 2 + man/cdc_baseline_forecaster.Rd | 6 +- man/epi_slide_wrapper.Rd | 4 +- man/flusight_hub_formatter.Rd | 4 +- man/step_epi_slide.Rd | 26 ++-- tests/testthat/test-epi_recipe.R | 2 +- tests/testthat/test-key_colnames.R | 14 +- tests/testthat/test-layer_add_forecast_date.R | 2 + tests/testthat/test-layer_add_target_date.R | 2 + tests/testthat/test-pad_to_end.R | 2 +- tests/testthat/test-step_epi_slide.R | 50 ++++---- tests/testthat/test-step_training_window.R | 2 +- vignettes/articles/sliding.Rmd | 55 ++++---- vignettes/arx-classifier.Rmd | 20 ++- vignettes/epipredict.Rmd | 9 +- 27 files changed, 198 insertions(+), 191 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index f1a8c3636..510725267 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -19,4 +19,5 @@ ^DEVELOPMENT\.md$ ^doc$ ^Meta$ -^.lintr$ \ No newline at end of file +^.lintr$ +^.venv$ \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index a7df5ba5a..37134c160 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"), @@ -23,8 +23,7 @@ URL: https://github.com/cmu-delphi/epipredict/, https://cmu-delphi.github.io/epipredict BugReports: https://github.com/cmu-delphi/epipredict/issues/ Depends: - epiprocess (>= 0.8.0), - epiprocess (< 0.9.0), + epiprocess (>= 0.9.0), parsnip (>= 1.0.0), R (>= 3.5.0) Imports: diff --git a/R/autoplot.R b/R/autoplot.R index d35850fd6..648c74e33 100644 --- a/R/autoplot.R +++ b/R/autoplot.R @@ -131,7 +131,7 @@ autoplot.epi_workflow <- function( if (length(extra_keys) == 0L) extra_keys <- NULL edf <- as_epi_df(edf, as_of = object$fit$meta$as_of, - additional_metadata = list(other_keys = extra_keys) + other_keys = extra_keys %||% character() ) if (is.null(predictions)) { return(autoplot( diff --git a/R/cdc_baseline_forecaster.R b/R/cdc_baseline_forecaster.R index 74af5e443..b2e7434e2 100644 --- a/R/cdc_baseline_forecaster.R +++ b/R/cdc_baseline_forecaster.R @@ -29,11 +29,11 @@ #' mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) %>% #' select(-pop, -death_rate) %>% #' group_by(geo_value) %>% -#' epi_slide(~ sum(.$deaths), before = 6, new_col_name = "deaths") %>% +#' epi_slide(~ sum(.$deaths), .window_size = 7, .new_col_name = "deaths_7dsum") %>% #' ungroup() %>% #' filter(weekdays(time_value) == "Saturday") #' -#' cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths") +#' cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths_7dsum") #' preds <- pivot_quantiles_wider(cdc$predictions, .pred_distn) #' #' if (require(ggplot2)) { @@ -47,7 +47,7 @@ #' geom_line(aes(y = .pred), color = "orange") + #' geom_line( #' data = weekly_deaths %>% filter(geo_value %in% four_states), -#' aes(x = time_value, y = deaths) +#' aes(x = time_value, y = deaths_7dsum) #' ) + #' scale_x_date(limits = c(forecast_date - 90, forecast_date + 30)) + #' labs(x = "Date", y = "Weekly deaths") + diff --git a/R/epi_recipe.R b/R/epi_recipe.R index 88ba605cd..0ff9efee8 100644 --- a/R/epi_recipe.R +++ b/R/epi_recipe.R @@ -95,7 +95,7 @@ epi_recipe.epi_df <- keys <- key_colnames(x) # we know x is an epi_df var_info <- tibble(variable = vars) - key_roles <- c("geo_value", "time_value", rep("key", length(keys) - 2)) + key_roles <- c("geo_value", rep("key", length(keys) - 2), "time_value") ## Check and add roles when available if (!is.null(roles)) { @@ -499,8 +499,11 @@ prep.epi_recipe <- function( if (!is_epi_df(training)) { # tidymodels killed our class # for now, we only allow step_epi_* to alter the metadata - training <- dplyr::dplyr_reconstruct( - as_epi_df(training), before_template + metadata <- attr(before_template, "metadata") + training <- as_epi_df( + training, + as_of = metadata$as_of, + other_keys = metadata$other_keys %||% character() ) } training <- dplyr::relocate(training, all_of(key_colnames(training))) @@ -579,8 +582,7 @@ bake.epi_recipe <- function(object, new_data, ..., composition = "epi_df") { new_data <- as_epi_df( new_data, as_of = meta$as_of, - # avoid NULL if meta is from saved older epi_df: - additional_metadata = meta$additional_metadata %||% list() + other_keys = meta$other_keys %||% character() ) } new_data diff --git a/R/epi_workflow.R b/R/epi_workflow.R index b059a81d0..f448f4aff 100644 --- a/R/epi_workflow.R +++ b/R/epi_workflow.R @@ -98,7 +98,8 @@ is_epi_workflow <- function(x) { fit.epi_workflow <- function(object, data, ..., control = workflows::control_workflow()) { object$fit$meta <- list( max_time_value = max(data$time_value), - as_of = attributes(data)$metadata$as_of + as_of = attr(data, "metadata")$as_of, + other_keys = attr(data, "metadata")$other_keys ) object$original_data <- data diff --git a/R/flusight_hub_formatter.R b/R/flusight_hub_formatter.R index c91f738ae..3e0eb1aaa 100644 --- a/R/flusight_hub_formatter.R +++ b/R/flusight_hub_formatter.R @@ -67,11 +67,11 @@ abbr_to_location <- function(abbr) { #' mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) %>% #' select(-pop, -death_rate) %>% #' group_by(geo_value) %>% -#' epi_slide(~ sum(.$deaths), before = 6, new_col_name = "deaths") %>% +#' epi_slide(~ sum(.$deaths), .window_size = 7, .new_col_name = "deaths_7dsum") %>% #' ungroup() %>% #' filter(weekdays(time_value) == "Saturday") #' -#' cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths") +#' cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths_7dsum") #' flusight_hub_formatter(cdc) #' flusight_hub_formatter(cdc, target = "wk inc covid deaths") #' flusight_hub_formatter(cdc, target = paste(horizon, "wk inc covid deaths")) diff --git a/R/key_colnames.R b/R/key_colnames.R index c69d1a628..b9ebde5dc 100644 --- a/R/key_colnames.R +++ b/R/key_colnames.R @@ -1,19 +1,20 @@ #' @export key_colnames.recipe <- function(x, ...) { - possible_keys <- c("geo_value", "time_value", "key") - keys <- x$var_info$variable[x$var_info$role %in% possible_keys] - keys[order(match(keys, possible_keys))] %||% character(0L) + geo_key <- x$var_info$variable[x$var_info$role %in% "geo_value"] + time_key <- x$var_info$variable[x$var_info$role %in% "time_value"] + keys <- x$var_info$variable[x$var_info$role %in% "key"] + c(geo_key, keys, time_key) %||% character(0L) } #' @export key_colnames.epi_workflow <- function(x, ...) { # safer to look at the mold than the preprocessor mold <- hardhat::extract_mold(x) - possible_keys <- c("geo_value", "time_value", "key") molded_names <- names(mold$extras$roles) - keys <- map(mold$extras$roles[molded_names %in% possible_keys], names) - keys <- unname(unlist(keys)) - keys[order(match(keys, possible_keys))] %||% character(0L) + geo_key <- names(mold$extras$roles[molded_names %in% "geo_value"]$geo_value) + time_key <- names(mold$extras$roles[molded_names %in% "time_value"]$time_value) + keys <- names(mold$extras$roles[molded_names %in% "key"]$key) + c(geo_key, keys, time_key) %||% character(0L) } kill_time_value <- function(v) { diff --git a/R/step_epi_slide.R b/R/step_epi_slide.R index 9714971fa..c7d3f9fbd 100644 --- a/R/step_epi_slide.R +++ b/R/step_epi_slide.R @@ -19,13 +19,18 @@ #' argument must be named `.x`. A common, though very difficult to debug #' error is using something like `function(x) mean`. This will not work #' because it returns the function mean, rather than `mean(x)` -#' @param before,after the size of the sliding window on the left and the right -#' of the center. Usually non-negative integers for data indexed by date, but -#' more restrictive in other cases (see [epiprocess::epi_slide()] for details). -#' @param f_name a character string of at most 20 characters that describes -#' the function. This will be combined with `prefix` and the columns in `...` -#' to name the result using `{prefix}{f_name}_{column}`. By default it will be determined -#' automatically using `clean_f_name()`. +#' @param .window_size the size of the sliding window, required. Usually a +#' non-negative integer will suffice (e.g. for data indexed by date, but more +#' restrictive in other time_type cases (see [epiprocess::epi_slide()] for +#' details). For example, set to 7 for a 7-day window. +#' @param .align a character string indicating how the window should be aligned. +#' By default, this is "right", meaning the slide_window will be anchored with +#' its right end point on the reference date. (see [epiprocess::epi_slide()] +#' for details). +#' @param f_name a character string of at most 20 characters that describes the +#' function. This will be combined with `prefix` and the columns in `...` to +#' name the result using `{prefix}{f_name}_{column}`. By default it will be +#' determined automatically using `clean_f_name()`. #' #' @template step-return #' @@ -37,53 +42,55 @@ #' rec <- epi_recipe(jhu) %>% #' step_epi_slide(case_rate, death_rate, #' .f = \(x) mean(x, na.rm = TRUE), -#' before = 6L +#' .window_size = 7L #' ) #' bake(prep(rec, jhu), new_data = NULL) -step_epi_slide <- - function(recipe, - ..., - .f, - before = 0L, - after = 0L, - role = "predictor", - prefix = "epi_slide_", - f_name = clean_f_name(.f), - skip = FALSE, - id = rand_id("epi_slide")) { - if (!is_epi_recipe(recipe)) { - cli_abort("This recipe step can only operate on an {.cls epi_recipe}.") - } - .f <- validate_slide_fun(.f) - epiprocess:::validate_slide_window_arg(before, attributes(recipe$template)$metadata$time_type) - epiprocess:::validate_slide_window_arg(after, attributes(recipe$template)$metadata$time_type) - arg_is_chr_scalar(role, prefix, id) - arg_is_lgl_scalar(skip) +step_epi_slide <- function(recipe, + ..., + .f, + .window_size = NULL, + .align = c("right", "center", "left"), + role = "predictor", + prefix = "epi_slide_", + f_name = clean_f_name(.f), + skip = FALSE, + id = rand_id("epi_slide")) { + if (!is_epi_recipe(recipe)) { + cli_abort("This recipe step can only operate on an {.cls epi_recipe}.") + } + .f <- validate_slide_fun(.f) + if (is.null(.window_size)) { + cli_abort("step_epi_slide: `.window_size` must be specified.") + } + epiprocess:::validate_slide_window_arg(.window_size, attributes(recipe$template)$metadata$time_type) + .align <- rlang::arg_match(.align) + arg_is_chr_scalar(role, prefix, id) + arg_is_lgl_scalar(skip) - recipes::add_step( - recipe, - step_epi_slide_new( - terms = enquos(...), - before = before, - after = after, - .f = .f, - f_name = f_name, - role = role, - trained = FALSE, - prefix = prefix, - keys = key_colnames(recipe), - columns = NULL, - skip = skip, - id = id - ) + recipes::add_step( + recipe, + step_epi_slide_new( + terms = enquos(...), + .window_size = .window_size, + .align = .align, + .f = .f, + f_name = f_name, + role = role, + trained = FALSE, + prefix = prefix, + keys = key_colnames(recipe), + columns = NULL, + skip = skip, + id = id ) - } + ) +} step_epi_slide_new <- function(terms, - before, - after, + .window_size, + .align, .f, f_name, role, @@ -96,8 +103,8 @@ step_epi_slide_new <- recipes::step( subclass = "epi_slide", terms = terms, - before = before, - after = after, + .window_size = .window_size, + .align = .align, .f = .f, f_name = f_name, role = role, @@ -119,8 +126,8 @@ prep.step_epi_slide <- function(x, training, info = NULL, ...) { step_epi_slide_new( terms = x$terms, - before = x$before, - after = x$after, + .window_size = x$.window_size, + .align = x$.align, .f = x$.f, f_name = x$f_name, role = x$role, @@ -165,8 +172,8 @@ bake.step_epi_slide <- function(object, new_data, ...) { # } epi_slide_wrapper( new_data, - object$before, - object$after, + object$.window_size, + object$.align, object$columns, c(object$.f), object$f_name, @@ -190,7 +197,7 @@ bake.step_epi_slide <- function(object, new_data, ...) { #' @importFrom dplyr bind_cols group_by ungroup #' @importFrom epiprocess epi_slide #' @keywords internal -epi_slide_wrapper <- function(new_data, before, after, columns, fns, fn_names, group_keys, name_prefix) { +epi_slide_wrapper <- function(new_data, .window_size, .align, columns, fns, fn_names, group_keys, name_prefix) { cols_fns <- tidyr::crossing(col_name = columns, fn_name = fn_names, fn = fns) # Iterate over the rows of cols_fns. For each row number, we will output a # transformed column. The first result returns all the original columns along @@ -204,10 +211,10 @@ epi_slide_wrapper <- function(new_data, before, after, columns, fns, fn_names, g result <- new_data %>% group_by(across(all_of(group_keys))) %>% epi_slide( - before = before, - after = after, - new_col_name = result_name, - f = function(slice, geo_key, ref_time_value) { + .window_size = .window_size, + .align = .align, + .new_col_name = result_name, + .f = function(slice, geo_key, ref_time_value) { fn(slice[[col_name]]) } ) %>% diff --git a/R/utils-misc.R b/R/utils-misc.R index af064b37c..b4d1c28b7 100644 --- a/R/utils-misc.R +++ b/R/utils-misc.R @@ -33,15 +33,14 @@ check_pname <- function(res, preds, object, newname = NULL) { grab_forged_keys <- function(forged, workflow, new_data) { - keys <- c("geo_value", "time_value", "key") forged_roles <- names(forged$extras$roles) - extras <- dplyr::bind_cols(forged$extras$roles[forged_roles %in% keys]) + extras <- dplyr::bind_cols(forged$extras$roles[forged_roles %in% c("geo_value", "time_value", "key")]) # 1. these are the keys in the test data after prep/bake new_keys <- names(extras) # 2. these are the keys in the training data old_keys <- key_colnames(workflow) # 3. these are the keys in the test data as input - new_df_keys <- key_colnames(new_data, extra_keys = setdiff(new_keys, keys[1:2])) + new_df_keys <- key_colnames(new_data, extra_keys = setdiff(new_keys, c("geo_value", "time_value"))) if (!(setequal(old_keys, new_df_keys) && setequal(new_keys, new_df_keys))) { cli::cli_warn(c( "Not all epi keys that were present in the training data are available", @@ -49,12 +48,11 @@ grab_forged_keys <- function(forged, workflow, new_data) { )) } if (is_epi_df(new_data)) { - extras <- as_epi_df(extras) - attr(extras, "metadata") <- attr(new_data, "metadata") - } else if (all(keys[1:2] %in% new_keys)) { - l <- list() - if (length(new_keys) > 2) l <- list(other_keys = new_keys[-c(1:2)]) - extras <- as_epi_df(extras, additional_metadata = l) + meta <- attr(new_data, "metadata") + extras <- as_epi_df(extras, as_of = meta$as_of, other_keys = meta$other_keys %||% character()) + } else if (all(c("geo_value", "time_value") %in% new_keys)) { + if (length(new_keys) > 2) other_keys <- new_keys[!new_keys %in% c("geo_value", "time_value")] + extras <- as_epi_df(extras, other_keys = other_keys %||% character()) } extras } diff --git a/data-raw/grad_employ_subset.R b/data-raw/grad_employ_subset.R index ae063d22f..38719a02e 100644 --- a/data-raw/grad_employ_subset.R +++ b/data-raw/grad_employ_subset.R @@ -101,6 +101,6 @@ ncol(gemploy) grad_employ_subset <- gemploy %>% as_epi_df( as_of = "2022-07-19", - additional_metadata = list(other_keys = c("age_group", "edu_qual")) + other_keys = c("age_group", "edu_qual") ) usethis::use_data(grad_employ_subset, overwrite = TRUE) diff --git a/data/grad_employ_subset.rda b/data/grad_employ_subset.rda index 3d74741cbd65cfcd114a7a224baa610478ee49e0..9380b43b5072674686e79ae494d9be9af2afc14a 100644 GIT binary patch literal 9546 zcmV-QCAHc@T4*^jL0KkKS^D6;*#L9I|NsC0|NsC0|NsAg|NsC0|NsC0|NsC0|NsB* z|9}7g|Nr1CyZ`_IH~@2`000aCIrIu5A|vIh?qHx6-$<{8Iq(1g00000008)X3QAEx z6beu&UH||O9CE9D+%)hWd)^0K096jEf1?0s0Wg^~(WWLQ0T_V7X`zrA8X5+MnhCTC zgu_4rV5fjgqZ1}WMrxVmJxrs~gvqJtrkON)MkYq4(?KurN(Ai)|kXu!k(mlz=kFxCQOWs zCYc&wAi^Gy#9}mIFa%&GfM5hli73&vJw`GzO!XxFQ%_=Qn0Zm-Pf(}nOrEEx+iIt% z-l??Oo~fEPq->|8dY*{djF~YS4LqiRdNPNidW@Q8k*BprH3LVcr>W{RX`|HjHl{{~ zO&+F(Xh*4#5h##NAOy{$CV?iIQ}ZKJXlPT(=pfY}pr@4bJdrdQ6V&vEMxIDC4Wejh z{ZZ;3NHlsQOw&+k(9_a1^&X>X4^gI#G(A9hL)0Fl5&DzVH29kP7WLkB7b}r+<#QUj zMT*9;)Q)1V>DM5QMqnKwbGK@tD5C(ZFh3++m^Y5Mm9~( zS9ej&ZOzW>w=7)gt;@T$T<+@RT@9IwxbB)Zxw%q1jdODD>D^rAlXDi=E2M6lk#iX7 z%UvYIa~rwTbPnsQo0ZP)h})X(F6Oyi3!I~K@LR>>qUF-(_g99+c$W?{7ah)BZpod= z+lq5@F6)`y&Pm+s?i<71*F!>HMR{I1<+{9&4b8gl?;bnEQ+;Z?&Fu0 zqsb#~_+&gxNjaosv@x+KSS-FF>1iMgHKcXwWr zuDmYgOy?InyA95}h0eQg&6mcRDf4ySd!muID=IySsNsbGg$e zcPDppc67UNuI_Pnb=}uH9FFeiM|Ui4yP8GL^4>gnyq-DZvE*IiUCX;SNDkq5G>3D$ zhZj4YJB~X9QArXIWD^uo3Wy{KmSE{Q5K)4}mNecK4dD=iA_zl%slI9~CAJIJgs*S9 z${_J_#J40<8=WrX6Gov~H$Yv~=hb5%Xf>%qt|ma)tn5P?PTysQs2FFhubP=a_%QO%wwWix>UlOut`K-jBCsxBrEYK=L zGicKq=LVbOi&JLTz8JcTwB1-sRfbL(j8|b=vzYWu+8cgxKf|Hg@_aU?(NT-G%SM^m zDYMueTU&8D+Y&XgSkcY6UqINc-?a3MwPRV=(XIAh9KBxSbDNshuH5Kh7rckuXOW~F zG}biZINUR^+#z}B@m*8Dn8R6eFVRjtD?bm>v~F*@BWtqDZ>9!v2iDm`QQCBEbxm}Q zq*@9g5wpv4o+mYN*{!zb^3Q9QWtiJ2k|bmjkb;FWX-k@uG0r6-OTD?rw8BhU&{cLt zCXl~M&7W@FM1`_pI0o~utd2@Tq0(3f>nAZ%twnat!04}QPLaQ}n{>Pz4t$5+r~TXb zoj355Nvt%Yr&fJzw3z{60***K+X7+@c(8@UB?{DNVB-jbT%hRBtXO31>=WSH5S&oHcv)_2DP)hY$_!5d$Nx!^$tTQJ4^%Az|jHvY#NTOD7K*EE8gQBn~ z#qgx%kHXP~1PG|uFTQWov(n%&GFE@a?bpxQ2f+O#{PIwGJdch);U6_sm)TZY2k=jq zQTq5EeCN*kK4nJ_><7KO^?PGKe=lpka6kI-5Thg0w@0jfo(&?N-yQjYRBj~p&ThfG zAPSL+h>ImYpi9jsJqt`gX4)0lNrP9 zCNaDwP9lr~!2(8Oep94UNfdIcp~C6KxK!X6GX9X5;+Z-2lxW5Cka!R*1~@BG+7g?y zQi@fPxwSJ_89!SuklRRh|E25590f#eFuj;u(6!T{L0kU>sIdlPdC=EL)$F7Hf&6Z8_S z#~PASX48LGCPiBM-^)A`FXSjJ6WBC^SH_;L97FHqSuy2OqmK@Ss@A#z)+8f+ZTwK& z7eG%k)`+7pzy}1NrqDPdrmmL2W^Niq=g7PDn1Fn=&kTGuVHOlH_p`F?fr+XQ3V)#C zxM-Briz~#4(64&I#&yn^xQrLY#g|q%lJ!{jtY*7#4v)L3_ld8Z)7vI*M*s3NO)VXZ<3bfhS(@|TGQlu+kST0i9BVczKz2^pu zqBaF>^~waE4XIAQC3`EVTzguaf^SE*H+Kj(i;af?Qn9sdxG}JUAVJZOi!w^;_9{J2 z1}*%uTbX^X=+X>EpxC>bcRjI{ z371e)T06`>R^CfaI(JGQfIOst)#(r2Gqt%2wppxAScp{m56RfwXzUuudnrR(vW}Ka zCkhA#;+Tl4e>(2!4UA5DI)v`2oDq0pWVpbquYiWwtbEW~^h86Se1WJyAzZ&#pv=M43vP8eiwjb`zjwUvp+ z?&u^~S3T`HX2snM)>k-u{WYps!qlqHl5&}q(r2h_8(z<0nljR!`0CAsxF|s$Wafbl zLZCWwQy^LJaiUReRdiE|wFwECw6ie+$pXTy6$+5`VJ}k3A|cr^LSdM`yfrG~+UbdU zl8u<0Av_?#ff2QUpr-BD5qZ5Rs4~5TtHgwyGgv z;>4mT7WQ&TK)BvdD{ikbldj%g-corUDCcl!2Ot3`C?&ZW2%v|VP&R-;JG&JIfYb=aN!tYq6arF;QUrTj z8kK=4ZF$#x&vW0_!ek#y6L1BaJIV^!HUY#+5UG|kD))_D66V)=KW(=ac#~yQOBGFH zt*Y>rwSLc4b8Km^p=z;Ps=QlP^ZTg{y0&)}Hi7Y~4FHEwStzxr6dF>CK`dB>Dp~^B zuA(?a5EeUKrs9&tR0Ti2Afgzes)JixTG&7mxO$#7mGSf?Za^KYu-Y_;3LG}sKutP` znk7XzLJD{QDs>2|VTh@hMN)AHqN3SAK?OE21Qk5Zr;2*f?Szs*5h=Wlu2^Ldh(%W3 zRq*yrv{cHfyrtn2BB>%MdV=Mb?{4c!u*aQwjR;8y5-0)aIf)y2y;WU=3(hvx8%C)j zR}M8ca==AvdQ$3xnE;T3O0-l+G-OazJ9owcL=wFrW&o3uCLr+C14#mcf_Sk6QE})1 zBt#-X0t8YD2>^&HBt$?8BA_WE8kmBBv^?K0UxdgZWi#_+RkUij3weim6q9uLVDF5$vl0dCY z_@DegRo*@1g@7%-&?OK7@x&t@SOXAj&$ILe1tQM z?tY-qwucuwfQV>KK;ciF{e1ma*eGCh@HG(wC^zm5uMhNImrq+z&2f6J?9Gf!*MzyS z+G2u(s2#Tns3!z|bv3tz1Q$ii3SoD~S%r7mdXc`}4G_tg*#V-L;S&ABAm1H#D`|r_ zpW{!rl%*;EMH+qODL;&*DLu6Q4@bdH<~uA!aiz-KCd6|5l(~JJ(p)c6^E&ZzwaN z4yYnV*aFg3GG zx0ohaVda^4415PHk(ggi<#Sv{_V^vCdym@akJ5M?Vf7(KA)v1obq-V5apNGn zs^{IxEVx|M%gpegL#jGTEK+Bw5F{9cBbkYG9>2ODkN-}h;lzn@vRJtnlQe@BGT-I# z z85yoWT8f6(HJ6xjFt*z zyxDFMCX@qg6jVt?NwEba8Yv`Agv6OF%w$3e0~Scdu`^_>8Zu}`AW9&O{UyoH5e{Q? zSaV!UyK}nkYo>^d1xjMuiEE@;nIb5{LX1}~ms|m2cU>k(N(hLYx&(nG2#Qji=pcfE zl)@GJ#>G zC`v>lQ$bClWXMT|Bus>iQV{|K0+S^q4Jgr=ymwfH0Fp@&CYS_Nn25zOn*|U87GP-8 zB*baqbW)N938Mxy%4tkvAjZKF-E?gbk`p5m6DW{2GE9iUnGCW}Af$M3iZK!a8JJY? z>IoW(WZ1D9n!Qhj$P}l1W5JM3j_c45LO!Ws#9GCW#c0jDVIT#6^@U0!tvN zV8&otNs=^#l1+dN0Y){56s8E4QjHN1Ln2^NjTDG#HZ*Kf=V}UKLYSmT#8VQ9OBBOF zvV#i-jT$0I(<~%xR8ff1G>n>L<-kZ8F&Zj1G|8sL0i;VMNEDMPCQ}he(J?3p#F{cj zreKL7ATN@=8^AtEuP+nVm~8z#YkN+`)jj8nUEqa}pYX(1yN z5T=PKD2!3DsM2j3PxET3{;#%ww$--w>Os%D6Jm$Yd4aoexSvPP;zSkN1>BEd9kv;= zB=_Bd0&JcC=kPqesAyv_cBW<8IRrrU;k1PA|F-K@B6J=p#>EI_xn~%XIbr#nXEPj$#os1!VpesA^RD`TqMMDBE8}O7KjKyAQpra60l?;BP0=MLMKT<3i-%`Xg`?T zSpXONhy~n!Yv|e-BdPqxC!Qh4!slzh&(RP*qhU8L^Z;3Q3vMWLvjXzmB+vFdV_RA zNigfcv;_;u`*HN$|EK#-uH24+ae(0OP8X@?TJ z0$QSVVhZdKB>?474pjsdtxhT56*#wUfK?O=X~E#oPB&+HP%gIs5G@Don&`wqv<9#c z3rHYWU=R>~A}E$!Q)AsauMz(a+<2|jQ98F&+kj)0K?5(@uxEF{op-y4rpdO{!IOB|=br3BgiRXwbyHKw90~qLCP`Jyf1VFk7H4T!~;O}XQYoM@+ z_W|uL-A8O4MreY&M7rycy>%21l86;pk3QqUaAP zieqJ&zfn^mK!Ub5XoGQR2sAdKwe)XV9b>T$h#JI)7a2hegA!!)M7o?a=65==C4+Df zakXfQ1@u6OgOUh7iQ$)5uI8x+$k^WH1C4B|wH_-NK7k9CFR{8ymBB8hzgyXSt;k-` zG&#W&oEANKp`7*RdoBL+@?Z3okVe1A4i z7f1WsS&sXJy-YX_&+hFE63sf}wFAwm81jL1Z&9(u4pJ99v=b zgca0Jh5|b#M51NrkR$qjpu+OZUv{Ru19dcsuedgy#QJ^LpEx_)d z%c=lyYE40q=zb8koRHD;Vb)9w>kKr5c`&$8Kg+;v1}1j_uZ39I{}gHvR7Fa3QnZ4r zpLJbc3}WFjK&T->)C1ph^|%yJam&0c_bw)I1zowGiu3W#E4V1u__PDke$KFQj&L8t1_0KBjp_lT1WkURsOB#fyW?j(Cn5yeb z`XMrjl2oKZ%6+$yOZZ2JHKEF|rzIgHe77{Pq=^vElJc=D@CyP?AvJAESyPlQ#W>8d z@{AyLM6OXzoAf_)kvrIF7-vtiMrEf@0|L2_n4C+5PLxN6<62ppEe`Y@WpgVCwUAL+ z5Vk)@0c#9r(wbAoU#Psh$FCevDctKAok}(n*}+FEG)3US*cNWUhr*{_ePPcK`k25w z3+iKI8)b)?zPy&osY#Vm=Q=TZtO?6^JzR!~MaBojaMgu7O0d|@?_a>Hq02-!_IamX z^KhQhTy>>c>mvf^2s~v`mb9TNwL+djEat*Sz9~*rcDsa+@k3G=7r=i{T(-3>W;Hlk zy&P~7wLh67pKCK!0H(gTBZc97iDU;inmiqS9I6=2G&oJO!j3PcJ;8M<3dbpxqk58r z3qNtc@!2$S3#E0UC72TF;Wi1?1Hn$+&@9>qC0;xl(|=E8ER4r07~Ppf_~WQBR z)pnk0^wJiYozRKzs7$>6K;aW}B zyH=^qoD3rPS7PyBJX%5Rj9y@JY{u5)dDT8{t|pfgYQ6(eS@XONJi36kP23aVQffz@ zJnTf+leB_imZBP3|BE(+N%Z5;wl$XjS5PgP6@+w3C4Hwp{|0+Kz5zsZ+%W=8aLZ*F zp+xbysBruporTjCGqRaI>8~*4BTH%AL_?^wIJ@;;MZ6wr$S5w95GXK!%cdaAC&DQM zlyx=UGc=`cCEE!W4KB|BhNSPfHfR%p3E18v0VG2Z*ED_%V|T4$Yl|Rx*>`p!5=K@Q zVPMM~W<^XMUOiM?$s(C#fO6-=d$4oR`zEA?3zs!TgrurR?>_*b#UOUBD&mxnNAF=I zJv~2ke!T~`K1BxXnU)6T09rBX%#5B^MJjwZsNWxMrK-->+DRxaewT8&G^iHL9mA6- zZI}j~V)tth>}SI{v=eiZ7uRwZ!qDzgCg*V(K--Yqr%xc;jfYZh7J;`T-S)roQl51R z{mg}*u{>XQ+keHDt!5kfC5k$|_8}=#b$H1Llp=lzE9jV;>wD5C0;8U@Ni+h6d!A_w zWpjf?&ug4O(KFymWKT#ON)px_nr7icc%DwLdPtQXsxD$TwNogxm$^ttKr)i1m|$=f z)4>8t22f0{07jWa>YNlZqq?U$wm5*O2j3!}&n{QB@*LRj2h=aU%X29+q#X6>T&aEq zCLsRZ8jQ<6H_QVxgW-Q*2nc>gz$gX`Bp?tnU=$7Eq-okgn==%bS+nR%xlq1^@c_Tu z&9<{VmI7$f1YjH}nz*F{6f*TfCK0Z#T`-I~9v4LD)TVEsXJ`5MOyq|UGs+pv&| zCwIdRA-^+Zyl>6;6xQ}M4g%o}1y9!ayAKc8@xER^SEK3i%Bkx++T`QcQI**nGs_E_ zCWxNq(ed#cq3;8DPCexDa)9&UM)OCAEsfRPjSEhPW~mO%{!{*@{K}95^c2|uC`Dz2 zWS~J;ke>hYJFT(E_J5L6Kp;wqAPtN5N%D^&;+ELFW$hQ{FZ~ymFjQ@kbnND~y7odN zm7+XpzRX2Bw!n`DX#ts)hqm>L#zpe|*wdS(5Q=gATF?ykFiBiAo#t^i>N=C|*K>}T zK@OpOjLq1pfYPc@%Fr|b0)oxV9W)lBw;0GMURGgS7aMZ75Yn8qSf1pgN&bCz99KP< zmh|+LM;B$UWuIg-qVyQ46v>|zCTR41GadesQ^m z5uu?&(6*0dCR}*sN~%YjqPl2thU9#OlS%*+o1UWSzpz0oM2(_Qn=3_{Els*uwM^tW zDvjSE#r%$)#(2)3oAMrbq)9y3NHJo~*;f$I3v-giF_#Z2h(s>kR&`pC$KbB*fWx0y z5L=)vT6+F8({E2NPE2n=;RUJ%hH%-1yP9hz(;q}C?pjhh2YxT9d38-|-Q%p@xc zez8?R#fHXem3?Si^^*%%1cxf0T4c!403(BcC>Tk+&o9W|zn>!{G6N&p5Hbvm^xQe_ z;z=jz=sPU-cVAD^p7u{e<5RWx9V}$PhVu-GTm--wPVK=Vly1xrCCm?0V1Wvq^7dP@ zmE9-M{4WP~7L&i=5cjm9y>dd;_j(yQErvXQy~o|Dap~2 zFrd5Si+=Jl95||!i){eUj8N}1cj-tDc{!R94A_Vq?zVubqW6?R-vkijx-?LFet|Sv zsAPl%Bl^9AQWQ0NEgb+ETLGAr4KAKW-Yualiv{#Z4PZ}zoh5`raMFGkP zfyv4W3z9%i^RU*|gp$P!3`D`A5<-AsVkV1*5tK&>1aw>_5jW6NeD*NKP#@HS@4EUR zJo8AD5MF1ili&E%rHTrB2r3wj{Q*ov1P|ZcX7Cu60GODdZ^JSYh>j)-@65^BN0$x%>gnDu8B@N0rI=J*UCnZn#7VE{bT}G%DVN1#d7!JW@h3inu}oUWHi#gbb_^y=t^8l46DALAWBF?c&i#euMeUOS9%`{C_Gb*$IAGiA8ia-L2 zNCof!1BT!Ld(~ch-h&XJ8C5^pGyu?}g^fU~n21%yTl*BMh z8kscpPevn5nrdo1lM(7;Q)#K>^+ukaM9>;-1vZS6)Wm6%Bg%RZ5RpwMihD^t7)?x? zd8iLm*qKME`lq3$r=b}%Xk^4>XaEfZKxohbqd;Ud(9xgL6RH{;gK^OoN00LkD5t9G_0GI#(01=SHFaRb1000000003n z000DFKq8Vrg)ym#klKwj@TQtHZ6g{8XwxT&JxvV(qX8N;13(5rq3RlFG}A*PO*Cj| z0Lh>RfDJMRO#o;B02*irl!Y`VM9Jvb2#RJhHldI-n3VMWNv4{fQ}mgMPg5h*(?*&b zQ`Buh4X7TF!g(@{sQpvadYdHK3F(y6M#4=D${SIkk?J(`jXbBR>KjwkdY-4L>UxHs z1zwb+7D_(tsKzyOT)QJtXg7CU?&>Nn-E>EHUEQ}`+eXx9bsKJ#1#WH1Hlu7rMRRS; zZ8^r~Hs;-!&gj=FEpvvE*F{e1jm~a&b|*Ty!(7)3yMm5sb;YF7$k#DPE1cY`oW&Jh zVd2=k5o3kQxm>PxZtJAj>2Tb+u1z>QuI|h)2JmX|S9ccne-8(TIlH=ZtX?N|9tGDN zyPcs!mUE=KcXkNox^nLBMUG>;i>23dlIy#+n+T;0bd$8)-Ob4Pb> z@owbs<8nKlySqnl?Cy+rbaR=>*Ctm^?n|!e-LCGgxhF2@ySXLO>!$8HM~p7cO@*i@9~x!=&r8sUy3&+1XvkaYU2~p$R0CB&3o- zB!M5HG#P~^j{yd7q`$6k#IY!P$Z*zM$y6ktnE^4RvvtR-AmuYKZTUo_f4uoPy2v1h zUAcoD!9-!9Ftt-6GNyDoSB3|}kg3hA^F3wMrFC~^#6N7)aU||mkpYOE*9Pu18V$Lo zT(Q{SOf(UNb*1!Oaf>tv)(OEJol#_x;h1dSGe%cz96v1Wi-Lm*M_@GAXSTdoQ%<RAJ(wDYIgTSMU57F~0Etyj$~6D%FBG~_#Doxkgg)F}r})fdvwEoNu9_4aLE zrf{mU7$0`{@E5}^ce>ho+Az;nxgoCkGe(jvT~l#U{v#faV}$6onf39{`LpF0*~8=< z42^C4sm{RGR-x8@3kTkPB^tP#+bx`B)ZDhqHm=VIuyPk#yDhDtCR(_r#U5mjUmOePuatA`AeWpEnOlcRiGSv-sc`)&yld8j6AQfRWB+EJ&xFDB= z)Cq9gl5#V2YLQv7fC|a=y8Y{Z#H#JCen5_w+0OFytp#t2ec@M^8|(ThYx%Y;MhhER zau-II@###w>5e9P#qRK9)u`zbbm4cELAq!gpf>P@|s) zjr1w2#t>$_@4I9`3!H3YSpP^z6;9O%)2KEzO?m5ggV$DRTm!YgDL4bD*$4( zMySsnGn&>#gFghJ)ki@7C)_TQ*mkEp;uhh z-6X3n4)p(6MJ@dY*CKN4iDElmP2w$#9jij}P(FZ^pvP#QeFEobY0-J3ah$&^<*cGo zR;DOhx~U#rbAQ4RJ~{#@PR`THqWRCR&+@MV6&Vc6KU`fgC}p!Cu49O znKGwYM3`-)-vk#Jycu@)3zf{4H-{>sg{x~YYGl(G9tzA2+Krm-J9osuKbBgEQyB;I zehRr-Z6+X{_nie78w%?w1rcB#SWy7eKQ7GMOTofeMWQhPwP|5zFw)LX{&G``3;^Vl1)Z z;`>f_hjL<51oBXw@gURFUkBK3qpd zmFgzi?asl#b)Ag|S3u-dBCD@QGuC@!#+7lWjTEm8zc%Ldj7V6`at5rA7=%M~qTL(I zML8OpW%X90c}Pn!pV6k?smCk_5{L;$u(iz*$>lb-KB9>}2sRg~=-pMaCxJA|RHT!G zF?m8Ppg@?WsT|R)44cNGPm2m*?v#1l3s_*&8f}(8kVjdmu^V?u5V~$^rO6spddxW( zaBxygE3SODvE}khvv2P6T07k!Yd?fG+c9}j?KP;zTSanb4>-$-aNfBox}GZxZAU6< ztg9{*cm?gQ(W#)KAn|b1XlbNM=_^sI`P2o{1Q7dxiFgPg1P53VC8-?ij!G*o85L({ z=8eBqWv7{!7o0BuKi62+=C+8iyiOK>achDk!Z6Sak}|60t%1u{67Dgx%UPv^y0hB1 zuyS1xNFwir=LIE}1Y;QsHJbx_JH#`h(?tpHUa%ptSlJ64B{HgI4wtHo&g9Livb;1B zSf*J`-NCV(*I6;Wp12=F4`gyEHN~Kt=2JEZXJ-u4Tg?V|t-4$@VQ9kl#)kl)q=VoyD?x(EnQ3NV(F)`;ItnK<%jY9```)r5x{xr05e5@b!CG*E z6_^f~Gdq`Tj2@-Hb+B~cx{)FSD_BLUSwf3#;CPLXpI)pRTivhs}@Su#)v zN%E$;rGip2!q!Eq55Xcy8meg2k}KB$)Pf{RphT;HLa0%aBtlXJt60c@6`v+01Xmkl zB!q1RgBdaEJZrcKM!MnBQql4=GhEFC z1<7Wqr$k0_c$<7hbT&;Hn|qes66LQG$?f7BcqNw2G+Qe>TWch^j}M=C+iTqAH>N@IhA$ zKt(%R_?1>bL&d}3aI3Rj&RVR@b{yMku|WeHq)-z~q9=f;r}7}Cqy-A-DY=cDR_q{1NFX*H7|4Ml#sV!QBmpD@4rWF^KF=?6 zRg$fBUaiQI5tC}$%4Qg^9je=*G5(8fjYf!-U(2S(Rw#}>x>Fz&&Wj-ul{5tlAyp)# zmut(gr6iQ`%#luNedc z?qYFuf$zV@N*v2Tlb#KP-|m6Q5flI!*+NJne@=N@*!b2eD0UAXQ4mx-9}~~!RtDQ9 zf-BdMP*FXkQ2DR`E1BNnkKpHqaDVXUg@B-E1Qi2*XF!CQL*;ro{wWJU=aEHn7i)%U z#`qKkE67nx;FwbQGbp&rtqGcVU7x`Ir_lN~DvQ4zsh$U6za6uT3$=9zY#UueY)DAs zBALN8Gv;xqyogu_2JHj@--k@AJzG2pVp(>KfX|7h7ZXPbBCWRnYfGx%kq)!&>Ph2$wa6>Rc`Qm~~eV zgV3$uy6idgp^%QT>GUsCGocOD;4(OmQ0~vL_!^Ew=q+jOPRwXzu|~sRh$y2bID<>3W^D`hPh587{SZnpy2zqB}~LCE40l zc)pW_x>cO1LJPlO(6057spMU0b+xh{;NqU)qwV5*e=J+GB4ya!;rDtw9OJIYqWC?Y zw8(*h^3tdFRrEG({%MXE)VyAuyC$j731P{Q*)|u%f_Sg9Jl^(RepX<%*wSxW6r@?? z+f~w_tC3b-JcDmw+@i;4XB1?aUyoF?_e9pi8|I!y%b&My;m$yf_M-% z6}pb@JxH%jg;fIvkGFV2Lw$b*8fH&)L!?=YU6uGEcYxgWcQpKfSf*0?!%tR z-v_Pdx7);$l$t_iq_SayGYrf^2x2mrB$$d>H5sLnB+$boWLPu?rjSXc5sM~8BQd0a z(gPA%7|BBt0g3>d1|b_LNFz~znS?YNDKT0CD2TCyWMf8yAu@>>Xo#?4q}C}hg9)G+ zqM$Jp%0nec7Bp)jU?E6}h9tpnTXfJw%>-j?ltzjz6__SWhy+O)B8bEwWHo|~8VpoL z3`j;{MI|MA^Qg}5w>c=xQ**BCoZT#J6(JS7x-}a!2}+7fcXiwWib*-SpaOHUP2IX_ zk}!*#r4ls=g52OpkeLF+P*Nt5BNS&hW{j9*rddNIVrG;hP%=$-ZqkVo3Q3ldW+^5i zxpXNI2xzgnxFZsYicKU5Bt~GOY(Nzr9lD5&3>ZlmlO{?rWRWb;WYjQb z8Yoi&z!=byQHV4|n-M9aW>O;{P>^JyNkln#cv|d4VP;5z8Z00NQjrp1Vwn*oiV_S` zXu?oIi~=T1hD?BwiI`1<#$;%ug2q5HCSjDNG-OId!jh4qjTA;SV`3>N!4N>rfee-` zP!TX;69_W|Ofn>r#)Q;N2$KUbWWf=%#I(w3Xv~n%N-45N2q=*;5GA650VOg~kfRZh zsHBP_G=`)ogfk?g6lelFxrA((jRci4NXCX3DKr)$!4)MK(+nFVVx)vDSfZu{NYaoD zhCrhPRLq2wjFOTpVv@;{0!j$X)LTVK2G}rYlLj!FCTtYSB8rU~Brz6)7BW$w3{j#P zj7mmA2%s$nzXq#s!>wz4j@sA6*TnCUZ6Y_8mm!_|seuvAm?#L$xpy)hI-q7K;=U|Z(s3A{3{icZw!ihN5j84_(<&zds=ExOT2+<^h+imcNY1_!-`(;eReBnc)1frrK5b4qE4h;Na|kE`#uyVnSF z|6_1IkcKgqV@euwg>OmPR@Gkev{F=f6tA@_YZkz_9_e=vylYNK%#V#T;Y5Gsiw zBxHgu2t@qVRjbZaOCKD)TtFWrfMeg1Ej#(-fkZK?Dr~@OionJ`dW!8qTSY{LM2~<` zXwC(3)bRlo2#8K=0?S^awDk1t#wZ%)6{td_b~q{+rXq1B)^TNG^`K@Vtj0b`P&Ciy^2a5!NLMTm9=Wfjt0@KBkxDVAq@@G?W20+tV$ zu0Fg0a}c$!y&#lsbYkY>-%il0c1!hX3V}V5rVd3pyz+o)uDy{WVEvE3Q zv2DZ`_WT-MC#fiwnp1WWHg+w za1c_l%NhX{RXC|rdE(EJrNCfA~nj*cvhIi(pHNU zf)G}cqD&PiOz)O;J6D zye(sfNI=M-0?M)NA|b-)Y(PUS2xFwoIN)P|0gi@B8M>B@kRmxO6kMDGMQQ?|ro^k- zn$j{!vR*p!dH3J)n*)q`3==MG4*5V$odFTo?G+Pony8dEZqKULAV-a`Iec@1xeBXv z+NJ(i2#!MV4pLEZl@lH)u4pS265672M#Hk%b?+{*Jiga^bS@hI9|L2s$OCY(+;Rdt zg1Znz`?6y2=M`BdQ7PqFg&7$wsgt~?D}_E-XJJwv6K}utHud^-UFqdh{Hsd3u< z)}1~iY~EO8og~@${jJPDN~VzVZ{xxIwi9R8`<=LbC(uIMk6p&8(#eYx9$J6T&E z-D2WGK2)BeH$cKP#le0KYQNQGmCx-lY%KCAiwQAG9yZf)-_az0yTabfV4iMKaWhlo z3>Iu}*kZ(`0Xb?P*GL&cPA?WXej@vV&z8&{>QYI7u21&&9}Zt>vuscgN)?pNXqG0? zrPe8AZ|o8|u=kXEe|LPnQpw}#4%)u&tjLpMifq+?Mmg&rUWH=j59iZ|=_Ql#Ar~(0 z{=&U%2j~&w6gS$!9Bd`(z8=N$FqY?k0n|I32G5K{4CP&J&!EnbWJv{L@fY zR?%oo^j=%QKJUu%i|R=w2s73P@Hgf10Bd39xa`p=&(J8Fm}X5YfwHl(z^H|&X6us_@QxGKF>DeS&Eg2O zc#3wkD-qfd%%qa1w%=;U)N@*V)n|v#Eh3aY+LZjP<;z+Kmm;Ij-VT#t=1?u1bj?KK>1EB~b1|(IsK3`j zJjx3MMimERgN9X9gHAfE2%3PzjMcSfaV9S#gp8LZYf5@juxez1CeIIJHsg+R#s+ap zVA%m^XxdTXPDdU{D;otzMky!g_m)2%b{4^#6@-LteiyI zt=1i>HkY(Tf}6$ch^b*~7qk@#6>7&JF$!wUR~Jg&$fha<2{Q9eWr;Eoi~rLsBzT%cQHpj?td+fwKy!rfm_ z>CWtwr9L0ueJ@ULM;r`65b+J;Kn|16qAk#eN9=U)Nn56A1``5SVA3W9t4PBVN?<0D zhEdXCx(;O%Z@W#=SI#F*1l!If=G#{2xE8{zX6Tf6O}aM8@i%S4tC8E>l-1l3jXdaX z5+SEGKhvb_z8pJa(yFeql%%dx=aRcMa$MsRp44J9zP6OBIhePMDCe8Q>Pn62Fu=FH z4eUN8eH?ee2Z!c#oAa!&Qs$WwfxgotOKj6F5Q%Ln4jyO zJ=wx@_$7S@1)?3theGoVL5liSq_`RzZ6U!X&E33QXGz*o-LUC7{l_87>-0q}zS6E6^g4N4GDDZmO~zAphkJ6z^_cHcV#rFzma ze3p_$nCcPV`r>kv4^NBLNUZz%ayf#&?55!;ofnBDb4#0EA$QTl=QFs;Mp!c<)Tm09 zZ`xyt#90@P4{GW$G!sL#40*m+TAwbFafECO^1m;>v8&a;ks_T3&77IkZ!5z zVf##GA|%wzB;YHMGEt<{^Q9Nq!lGd;u=B5=oh+v2PFBv@y|I1528yCx5|pusr5edW zG6@^v6D#@;NSziUY23471G_b)Xyi#$1Y}H!F=It_0+SwMTFI@WGCrzF%0-#B-G5`% zySJ6vbQ@lSCeysb@qBMdzR-F%}8CI(fN%q?u9B5N4o`mVkXmUZbM`kPS6?QA@xdCl6TRR(e%D%+y{kwFz$9oWSzz9zjLIo)T8lccp3Bfs{1Qh0qf(m7e z46}{=DPuy8jldU5*tQAUz+yfJEqilia_+9t4{d$wWhG3s8 z{yvP<2%`+9#`BYLGwEona3owrRH*>1U<&}QB!y}~mH`0oP^I_?0KY&7Y*-RhFRuF~ z5Nhj4wMmd`88TM(wWN_N0uXO?qeNWTiRo%BvY|}UBIfE*UNiyUkWlIQM?pj6^*#2e z+7;ljK>CmnIZ;6`1Q&u|C@FM;oc{=Kg-YIF4vTz}f)_$4cG@@U5HH0I7X1_+i$y4a zZbB;VeNzTV3D+90Gb=F>DNE;`BCX`AStu7pfdfC$VoWjxVz<}}iNQfj;{NKaMi_<+axn_U0^ diff --git a/man/autoplot-epipred.Rd b/man/autoplot-epipred.Rd index 27bfdf5f7..10236eb98 100644 --- a/man/autoplot-epipred.Rd +++ b/man/autoplot-epipred.Rd @@ -121,4 +121,6 @@ arx <- arx_forecaster(jhu, "death_rate", c("case_rate", "death_rate"), args_list = arx_args_list(ahead = 14L) ) autoplot(arx, .max_facets = 6) +NULL + } diff --git a/man/cdc_baseline_forecaster.Rd b/man/cdc_baseline_forecaster.Rd index cd3c4ed67..0c7f1e436 100644 --- a/man/cdc_baseline_forecaster.Rd +++ b/man/cdc_baseline_forecaster.Rd @@ -44,11 +44,11 @@ weekly_deaths <- case_death_rate_subset \%>\% mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) \%>\% select(-pop, -death_rate) \%>\% group_by(geo_value) \%>\% - epi_slide(~ sum(.$deaths), before = 6, new_col_name = "deaths") \%>\% + epi_slide(~ sum(.$deaths), .window_size = 7, .new_col_name = "deaths_7dsum") \%>\% ungroup() \%>\% filter(weekdays(time_value) == "Saturday") -cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths") +cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths_7dsum") preds <- pivot_quantiles_wider(cdc$predictions, .pred_distn) if (require(ggplot2)) { @@ -62,7 +62,7 @@ if (require(ggplot2)) { geom_line(aes(y = .pred), color = "orange") + geom_line( data = weekly_deaths \%>\% filter(geo_value \%in\% four_states), - aes(x = time_value, y = deaths) + aes(x = time_value, y = deaths_7dsum) ) + scale_x_date(limits = c(forecast_date - 90, forecast_date + 30)) + labs(x = "Date", y = "Weekly deaths") + diff --git a/man/epi_slide_wrapper.Rd b/man/epi_slide_wrapper.Rd index 0c05b7650..d67db1c88 100644 --- a/man/epi_slide_wrapper.Rd +++ b/man/epi_slide_wrapper.Rd @@ -6,8 +6,8 @@ \usage{ epi_slide_wrapper( new_data, - before, - after, + .window_size, + .align, columns, fns, fn_names, diff --git a/man/flusight_hub_formatter.Rd b/man/flusight_hub_formatter.Rd index b43bc0ac2..b2be9b4fe 100644 --- a/man/flusight_hub_formatter.Rd +++ b/man/flusight_hub_formatter.Rd @@ -52,11 +52,11 @@ weekly_deaths <- case_death_rate_subset \%>\% mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) \%>\% select(-pop, -death_rate) \%>\% group_by(geo_value) \%>\% - epi_slide(~ sum(.$deaths), before = 6, new_col_name = "deaths") \%>\% + epi_slide(~ sum(.$deaths), .window_size = 7, .new_col_name = "deaths_7dsum") \%>\% ungroup() \%>\% filter(weekdays(time_value) == "Saturday") -cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths") +cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths_7dsum") flusight_hub_formatter(cdc) flusight_hub_formatter(cdc, target = "wk inc covid deaths") flusight_hub_formatter(cdc, target = paste(horizon, "wk inc covid deaths")) diff --git a/man/step_epi_slide.Rd b/man/step_epi_slide.Rd index 46bb386ad..242f8e312 100644 --- a/man/step_epi_slide.Rd +++ b/man/step_epi_slide.Rd @@ -8,8 +8,8 @@ step_epi_slide( recipe, ..., .f, - before = 0L, - after = 0L, + .window_size = NULL, + .align = c("right", "center", "left"), role = "predictor", prefix = "epi_slide_", f_name = clean_f_name(.f), @@ -41,19 +41,25 @@ argument must be named \code{.x}. A common, though very difficult to debug error is using something like \code{function(x) mean}. This will not work because it returns the function mean, rather than \code{mean(x)}} -\item{before, after}{the size of the sliding window on the left and the right -of the center. Usually non-negative integers for data indexed by date, but -more restrictive in other cases (see \code{\link[epiprocess:epi_slide]{epiprocess::epi_slide()}} for details).} +\item{.window_size}{the size of the sliding window, required. Usually a +non-negative integer will suffice (e.g. for data indexed by date, but more +restrictive in other time_type cases (see \code{\link[epiprocess:epi_slide]{epiprocess::epi_slide()}} for +details). For example, set to 7 for a 7-day window.} + +\item{.align}{a character string indicating how the window should be aligned. +By default, this is "right", meaning the slide_window will be anchored with +its right end point on the reference date. (see \code{\link[epiprocess:epi_slide]{epiprocess::epi_slide()}} +for details).} \item{role}{For model terms created by this step, what analysis role should they be assigned? \code{lag} is default a predictor while \code{ahead} is an outcome.} \item{prefix}{A character string that will be prefixed to the new column.} -\item{f_name}{a character string of at most 20 characters that describes -the function. This will be combined with \code{prefix} and the columns in \code{...} -to name the result using \verb{\{prefix\}\{f_name\}_\{column\}}. By default it will be determined -automatically using \code{clean_f_name()}.} +\item{f_name}{a character string of at most 20 characters that describes the +function. This will be combined with \code{prefix} and the columns in \code{...} to +name the result using \verb{\{prefix\}\{f_name\}_\{column\}}. By default it will be +determined automatically using \code{clean_f_name()}.} \item{skip}{A logical. Should the step be skipped when the recipe is baked by \code{\link[=bake]{bake()}}? While all operations are baked @@ -80,7 +86,7 @@ jhu <- case_death_rate_subset \%>\% rec <- epi_recipe(jhu) \%>\% step_epi_slide(case_rate, death_rate, .f = \(x) mean(x, na.rm = TRUE), - before = 6L + .window_size = 7L ) bake(prep(rec, jhu), new_data = NULL) } diff --git a/tests/testthat/test-epi_recipe.R b/tests/testthat/test-epi_recipe.R index ed27d88c0..a4cbb00b4 100644 --- a/tests/testthat/test-epi_recipe.R +++ b/tests/testthat/test-epi_recipe.R @@ -59,7 +59,7 @@ test_that("epi_recipe formula works", { time_value = seq(as.Date("2020-01-01"), by = 1, length.out = 5), geo_value = "ca", z = "dummy_key" - ) %>% epiprocess::as_epi_df(additional_metadata = list(other_keys = "z")) + ) %>% epiprocess::as_epi_df(other_keys = "z") # with an additional key r <- epi_recipe(y ~ x + geo_value, tib) diff --git a/tests/testthat/test-key_colnames.R b/tests/testthat/test-key_colnames.R index d55a515ca..3b3118740 100644 --- a/tests/testthat/test-key_colnames.R +++ b/tests/testthat/test-key_colnames.R @@ -30,12 +30,12 @@ test_that("key_colnames extracts additional keys when they are present", { value = 1:length(geo_value) + 0.01 * rnorm(length(geo_value)) ) %>% as_epi_df( - additional_metadata = list(other_keys = c("state", "pol")) + other_keys = c("state", "pol") ) expect_identical( key_colnames(my_data), - c("geo_value", "time_value", "state", "pol") + c("geo_value", "state", "pol", "time_value") ) my_recipe <- epi_recipe(my_data) %>% @@ -43,16 +43,10 @@ test_that("key_colnames extracts additional keys when they are present", { step_epi_naomit() # order of the additional keys may be different - expect_setequal( - key_colnames(my_recipe), - c("geo_value", "time_value", "state", "pol") - ) + expect_equal(key_colnames(my_recipe), c("geo_value", "state", "pol", "time_value")) my_workflow <- epi_workflow(my_recipe, linear_reg()) %>% fit(my_data) # order of the additional keys may be different - expect_setequal( - key_colnames(my_workflow), - c("geo_value", "time_value", "state", "pol") - ) + expect_equal(key_colnames(my_workflow), c("geo_value", "state", "pol", "time_value")) }) diff --git a/tests/testthat/test-layer_add_forecast_date.R b/tests/testthat/test-layer_add_forecast_date.R index 9595b47b6..915804d6b 100644 --- a/tests/testthat/test-layer_add_forecast_date.R +++ b/tests/testthat/test-layer_add_forecast_date.R @@ -93,6 +93,8 @@ test_that("forecast date works for daily", { unclass() %>% as.data.frame() %>% mutate(time_value = as.POSIXlt(time_value)$year + 1900L) %>% + group_by(geo_value, time_value) %>% + summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups="drop") %>% as_epi_df() expect_error(predict(wf1, latest_yearly)) diff --git a/tests/testthat/test-layer_add_target_date.R b/tests/testthat/test-layer_add_target_date.R index e5349839b..f1fa3f217 100644 --- a/tests/testthat/test-layer_add_target_date.R +++ b/tests/testthat/test-layer_add_target_date.R @@ -104,6 +104,8 @@ test_that("target date works for daily and yearly", { unclass() %>% as.data.frame() %>% mutate(time_value = as.POSIXlt(time_value)$year + 1900L) %>% + group_by(geo_value, time_value) %>% + summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups = "drop") %>% as_epi_df() expect_error(predict(wf1, latest_bad)) diff --git a/tests/testthat/test-pad_to_end.R b/tests/testthat/test-pad_to_end.R index 0ea6244b0..6949f06ac 100644 --- a/tests/testthat/test-pad_to_end.R +++ b/tests/testthat/test-pad_to_end.R @@ -32,6 +32,6 @@ test_that("test set padding works", { # make sure it maintains the epi_df dat <- dat %>% dplyr::rename(geo_value = gr1) %>% - as_epi_df() + as_epi_df(other_keys = "gr2") expect_s3_class(pad_to_end(dat, "geo_value", 2), "epi_df") }) diff --git a/tests/testthat/test-step_epi_slide.R b/tests/testthat/test-step_epi_slide.R index 29e046eae..e90c317f8 100644 --- a/tests/testthat/test-step_epi_slide.R +++ b/tests/testthat/test-step_epi_slide.R @@ -7,32 +7,23 @@ edf <- data.frame( value = c(2:21, 3:22) ) %>% as_epi_df() - r <- epi_recipe(edf) -rolled_before <- edf %>% - group_by(geo_value) %>% - epi_slide(value = mean(value), before = 3L) %>% - pull(value) -rolled_after <- edf %>% - group_by(geo_value) %>% - epi_slide(value = mean(value), after = 3L) %>% - pull(value) test_that("epi_slide errors when needed", { # not an epi_recipe - expect_error(recipe(edf) %>% step_epi_slide(value, .f = mean, before = 6L)) + expect_error(recipe(edf) %>% step_epi_slide(value, .f = mean, .window_size = 7L)) # 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, .window_size = c(3L, 6L))) + expect_error(r %>% step_epi_slide(value, .f = mean, .align = c("right", "left"))) 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])) # 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, .window_size = 1.5)) + expect_error(r %>% step_epi_slide(value, .f = mean, .align = 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)) @@ -45,31 +36,40 @@ test_that("epi_slide errors when needed", { test_that("epi_slide handles different function specs", { cfun <- r %>% - step_epi_slide(value, .f = "mean", before = 3L) %>% + step_epi_slide(value, .f = "mean", .window_size = 4L) %>% prep(edf) %>% bake(new_data = NULL) + expected_out <- edf %>% + group_by(geo_value) %>% + epi_slide(~ mean(.x$value), .window_size = 4L) %>% + ungroup() %>% + rename(epi_slide__.f_value = slide_value) + expect_equal(cfun, expected_out) ffun <- r %>% - step_epi_slide(value, .f = mean, before = 3L) %>% + step_epi_slide(value, .f = mean, .window_size = 4L) %>% prep(edf) %>% bake(new_data = NULL) + expect_equal(ffun, expected_out) # formula NOT currently supported expect_error( lfun <- r %>% - step_epi_slide(value, .f = ~ mean(.x, na.rm = TRUE), before = 3L), + step_epi_slide(value, .f = ~ mean(.x, na.rm = TRUE), .window_size = 4L), regexp = "cannot be a formula." ) + # expect_equal(lfun, rolled_before) blfun <- r %>% - step_epi_slide(value, .f = function(x) mean(x, na.rm = TRUE), before = 3L) %>% + step_epi_slide(value, .f = function(x) mean(x, na.rm = TRUE), .window_size = 4L) %>% prep(edf) %>% bake(new_data = NULL) + expected_out <- edf %>% + group_by(geo_value) %>% + epi_slide(~ mean(.x$value, na.rm = TRUE), .window_size = 4L) %>% + ungroup() %>% + rename(epi_slide__.f_value = slide_value) + expect_equal(blfun, expected_out) nblfun <- r %>% - step_epi_slide(value, .f = \(x) mean(x, na.rm = TRUE), before = 3L) %>% + step_epi_slide(value, .f = \(x) mean(x, na.rm = TRUE), .window_size = 4L) %>% prep(edf) %>% bake(new_data = NULL) - - expect_equal(cfun[[4]], rolled_before) - expect_equal(ffun[[4]], rolled_before) - # expect_equal(lfun[[4]], rolled_before) - expect_equal(blfun[[4]], rolled_before) - expect_equal(nblfun[[4]], rolled_before) + expect_equal(nblfun, expected_out) }) diff --git a/tests/testthat/test-step_training_window.R b/tests/testthat/test-step_training_window.R index f49668a40..a9f2170d3 100644 --- a/tests/testthat/test-step_training_window.R +++ b/tests/testthat/test-step_training_window.R @@ -84,7 +84,7 @@ test_that("step_training_window works with multiple keys", { expect_equal(nrow(p4), 12L) expect_equal(ncol(p4), 5L) expect_s3_class(p4, "epi_df") - expect_named(p4, c("geo_value", "time_value", "additional_key", "x", "y")) + expect_named(p4, c("geo_value", "additional_key", "time_value", "x", "y")) expect_equal( p4$time_value, rep(c( diff --git a/vignettes/articles/sliding.Rmd b/vignettes/articles/sliding.Rmd index ec6f67359..31cc7b9b0 100644 --- a/vignettes/articles/sliding.Rmd +++ b/vignettes/articles/sliding.Rmd @@ -54,7 +54,7 @@ applying `epi_slide()` to the latest snapshot of the data. First, we download the version history (ie. archive) of the percentage of doctor's visits with CLI (COVID-like illness) computed from medical insurance claims and the number of new confirmed COVID-19 cases per 100,000 population -(daily) for all 50 states from the COVIDcast API. +(daily) for all 50 states from the COVIDcast API.
@@ -69,7 +69,6 @@ versions for the less up-to-date input archive. theme_set(theme_bw()) y <- readRDS("all_states_covidcast_signals.rds") - y <- purrr::map(y, ~ select(.x, geo_value, time_value, version = issue, value)) x <- epix_merge( @@ -93,15 +92,11 @@ output. ```{r arx-kweek-preliminaries, warning = FALSE} # Latest snapshot of data, and forecast dates -x_latest <- epix_as_of(x, max_version = max(x$versions_end)) -fc_time_values <- seq( - from = as.Date("2020-08-01"), - to = as.Date("2021-11-01"), - by = "1 month" -) +x_latest <- epix_as_of(x, version = max(x$versions_end)) +fc_time_values <- seq(from = as.Date("2021-11-01"), to = as.Date("2021-11-01"), by = "1 month") aheads <- c(7, 14, 21, 28) -k_week_ahead <- function(epi_df, outcome, predictors, ahead = 7, engine) { +forecast_k_week_ahead <- function(epi_df, outcome, predictors, ahead = 7, engine) { epi_slide( epi_df, ~ arx_forecaster( @@ -109,9 +104,9 @@ k_week_ahead <- function(epi_df, outcome, predictors, ahead = 7, engine) { args_list = arx_args_list(ahead = ahead) )$predictions %>% select(-geo_value), - before = 120 - 1, - ref_time_values = fc_time_values, - new_col_name = "fc" + .window_size = 120, + .ref_time_values = fc_time_values, + .new_col_name = "fc" ) %>% select(geo_value, time_value, starts_with("fc")) %>% mutate(engine_type = engine$engine) @@ -121,22 +116,22 @@ k_week_ahead <- function(epi_df, outcome, predictors, ahead = 7, engine) { ```{r make-arx-kweek} # Generate the forecasts and bind them together fc <- bind_rows( - map( - aheads, - ~ k_week_ahead( - x_latest, "case_rate", c("case_rate", "percent_cli"), .x, - engine = linear_reg() - ) - ) %>% list_rbind(), - map( - aheads, - ~ k_week_ahead( - x_latest, "case_rate", c("case_rate", "percent_cli"), .x, - engine = rand_forest(mode = "regression") - ) - ) %>% list_rbind() -) %>% - pivot_quantiles_wider(fc_.pred_distn) + map(aheads, ~ forecast_k_week_ahead( + x_latest, + outcome = "case_rate", + predictors = c("case_rate", "percent_cli"), + ahead = .x, + engine = linear_reg() + )), + map(aheads, ~ forecast_k_week_ahead( + x_latest, + outcome = "case_rate", + predictors = c("case_rate", "percent_cli"), + ahead = .x, + engine = rand_forest(mode = "regression") + )) +) +pivot_quantiles_wider(fc_.pred_distn) ``` Here, `arx_forecaster()` does all the heavy lifting. It creates leads of the @@ -235,11 +230,11 @@ can_latest <- epix_as_of(can, max_version = max(can$DT$version)) can_fc <- bind_rows( map( aheads, - ~ k_week_ahead(can_latest, "cr_7dav", "cr_7dav", .x, linear_reg()) + ~ forecast_k_week_ahead(can_latest, "cr_7dav", "cr_7dav", .x, linear_reg()) ) %>% list_rbind(), map( aheads, - ~ k_week_ahead( + ~ forecast_k_week_ahead( can_latest, "cr_7dav", "cr_7dav", .x, boost_tree(mode = "regression", trees = 20) ) diff --git a/vignettes/arx-classifier.Rmd b/vignettes/arx-classifier.Rmd index ae1641cce..b2a2bbf8e 100644 --- a/vignettes/arx-classifier.Rmd +++ b/vignettes/arx-classifier.Rmd @@ -50,10 +50,7 @@ jhu <- case_death_rate_subset %>% geo_value %in% c("ca", "fl", "tx", "ny", "nj") ) -out <- arx_classifier(jhu, - outcome = "case_rate", - predictors = "case_rate" -) +out <- arx_classifier(jhu, outcome = "case_rate", predictors = "case_rate") out$predictions ``` @@ -93,7 +90,8 @@ relying on the default of 0.25. We can do this by passing 0.5 to the `breaks` argument in `arx_class_args_list()` as follows: ```{r} -out_break_0.5 <- arx_classifier(jhu, +out_break_0.5 <- arx_classifier( + jhu, outcome = "case_rate", predictors = "case_rate", args_list = arx_class_args_list( @@ -142,8 +140,8 @@ the present? To answer this question, we can create a predictive model for upswings and downswings of case rates rather than the raw case rates themselves. For this situation, our target is to predict whether there is an increase in case rates -or not. Following -[McDonald, Bien, Green, Hu, et al.(2021)](https://www.pnas.org/doi/full/10.1073/pnas.2111453118), +or not. Following +[McDonald, Bien, Green, Hu, et al.(2021)](https://www.pnas.org/doi/full/10.1073/pnas.2111453118), we look at the relative change between $Y_{l,t}$ and $Y_{l, t+a}$, where the former is the case rate at location $l$ at time $t$ and the latter is the rate for that location at @@ -152,7 +150,7 @@ with two classes $$\begin{align} Z_{l,t} = \left\{\begin{matrix} -\text{up,} & \text{if } Y_{l,t}^\Delta > 0.25\\ +\text{up,} & \text{if } Y_{l,t}^\Delta > 0.25\\ \text{not up,} & \text{otherwise} \end{matrix}\right. \end{align}$$ @@ -166,7 +164,7 @@ $$\begin{align} \pi_{\text{up}}(x) &= Pr(Z_{l, t} = \text{up}|x) = \frac{e^{g_{\text{up}}(x)}}{1 + e^{g_{\text{up}}(x)}}, \\ \pi_{\text{not up}}(x)&= Pr(Z_{l, t} = \text{not up}|x) = 1 - Pr(Z_{l, t} = \text{up}|x) = \frac{1}{1 + e^{g_{\text{up}}(x)}} \end{align}$$ -where +where $$ g_{\text{up}}(x) = \log\left ( \frac{\Pr(Z_{l, t} = \text{up} \vert x)}{\Pr(Z_{l, t} = \text{not up} \vert x)} \right ) = \beta_{10} + \beta_{11}Y_{l,t}^\Delta + \beta_{12}Y_{l,t-7}^\Delta + \beta_{13}Y_{l,t-14}^\Delta. @@ -223,7 +221,7 @@ require access to the training data. The other optional arguments for controlling the growth rate calculation (that can be inputted as `additional_gr_args`) can be found in the documentation for -`epiprocess::growth_rate()` and the related +`epiprocess::growth_rate()` and the related `vignette("growth_rate", package = "epiprocess")`. ### Visualizing the results @@ -280,4 +278,4 @@ to start with using the built-in classifier for ostensibly simple projects and begin to implement your own when the modelling project takes a complicated turn. To get some practice on coding up a classifier by hand, consider translating this binary classification model example to an `epi_workflow`, akin to that in -`vignette("preprocessing-and-models")`. +`vignette("preprocessing-and-models")`. diff --git a/vignettes/epipredict.Rmd b/vignettes/epipredict.Rmd index 7e24b04c6..1925de2fb 100644 --- a/vignettes/epipredict.Rmd +++ b/vignettes/epipredict.Rmd @@ -110,8 +110,6 @@ the *same set* of `geo_value`'s and `time_value`'s could actually be different. For more details, see [`{epiprocess}`](https://cmu-delphi.github.io/epiprocess/articles/epiprocess.html). - - ## Why doesn't this package already exist? As described above: @@ -121,7 +119,7 @@ preprocessing, training, and prediction, bound together, through a package calle `{workflows}`. We built `{epipredict}` on top of that setup. In this way, you CAN use almost everything they provide. -* However, `{workflows}` doesn't do postprocessing. And nothing in the -verse +* However, `{workflows}` doesn't do postprocessing. And nothing in the -verse handles _panel data_. * The tidy-team doesn't have plans to do either of these things. (We checked). @@ -131,7 +129,7 @@ handles _panel data_. etc.[^2] Our group has not prioritized these sorts of models for epidemic forecasting, but one could also integrate these methods into our framework. -[^2]: These are [`{timetk}`](https://business-science.github.io/timetk/index.html) +[^2]: These are [`{timetk}`](https://business-science.github.io/timetk/index.html) and [`{modeltime}`](https://business-science.github.io/timetk/index.html). There are *lots* of useful methods there than can be used to do fairly complex machine learning methodology, though not directly for panel data and not for direct @@ -327,6 +325,7 @@ the `time_value`, `geo_value`, and any additional keys so that these are availab when necessary. The `epi_recipe` from `out_gb` can be extracted from the result: + ```{r} extract_recipe(out_gb$epi_workflow) ``` @@ -441,7 +440,7 @@ But ideally, a user could create their own forecasters by building up the components we provide. In other vignettes, we try to walk through some of these customizations. -To illustrate everything above, here is (roughly) the code for the +To illustrate everything above, here is (roughly) the code for the `flatline_forecaster()` applied to the `case_rate`. ```{r} From b3e3189da970ac341fa0294b02cf49ee3899b0ac Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 27 Sep 2024 14:16:28 -0700 Subject: [PATCH 14/37] styler: style --- tests/testthat/test-layer_add_forecast_date.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-layer_add_forecast_date.R b/tests/testthat/test-layer_add_forecast_date.R index 915804d6b..6d0e637c8 100644 --- a/tests/testthat/test-layer_add_forecast_date.R +++ b/tests/testthat/test-layer_add_forecast_date.R @@ -94,7 +94,7 @@ test_that("forecast date works for daily", { as.data.frame() %>% mutate(time_value = as.POSIXlt(time_value)$year + 1900L) %>% group_by(geo_value, time_value) %>% - summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups="drop") %>% + summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups = "drop") %>% as_epi_df() expect_error(predict(wf1, latest_yearly)) From 374cb2f1673529e13571cb6e1fe11a920f385d02 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 27 Sep 2024 15:52:18 -0700 Subject: [PATCH 15/37] doc: fix vignettes --- R/layer_add_forecast_date.R | 1 + R/layer_add_target_date.R | 1 + 2 files changed, 2 insertions(+) diff --git a/R/layer_add_forecast_date.R b/R/layer_add_forecast_date.R index 02395f960..3d5ea010b 100644 --- a/R/layer_add_forecast_date.R +++ b/R/layer_add_forecast_date.R @@ -104,6 +104,7 @@ slather.layer_add_forecast_date <- function(object, components, workflow, workflows::extract_preprocessor(workflow)$template, "metadata" )$time_type if (expected_time_type == "week") expected_time_type <- "day" + if (expected_time_type == "integer") expected_time_type <- "year" validate_date( forecast_date, expected_time_type, call = rlang::expr(layer_add_forecast_date()) diff --git a/R/layer_add_target_date.R b/R/layer_add_target_date.R index 9176fb593..094ec8501 100644 --- a/R/layer_add_target_date.R +++ b/R/layer_add_target_date.R @@ -90,6 +90,7 @@ slather.layer_add_target_date <- function(object, components, workflow, workflows::extract_preprocessor(workflow)$template, "metadata" )$time_type if (expected_time_type == "week") expected_time_type <- "day" + if (expected_time_type == "integer") expected_time_type <- "year" if (!is.null(object$target_date)) { target_date <- object$target_date From 93a405ec1622897e9ce24ae4d667465b57dd5d50 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Fri, 27 Sep 2024 20:58:56 -0700 Subject: [PATCH 16/37] doc: fix sliding article and verify others --- vignettes/articles/sliding.Rmd | 180 ++++++++++++------------- vignettes/articles/smooth-qr.Rmd | 27 ++-- vignettes/articles/symptom-surveys.Rmd | 12 +- 3 files changed, 107 insertions(+), 112 deletions(-) diff --git a/vignettes/articles/sliding.Rmd b/vignettes/articles/sliding.Rmd index 31cc7b9b0..1556c4a72 100644 --- a/vignettes/articles/sliding.Rmd +++ b/vignettes/articles/sliding.Rmd @@ -25,27 +25,21 @@ library(purrr) # Demonstrations of sliding AR and ARX forecasters -A key function from the epiprocess package is `epi_slide()`, which allows the -user to apply a function or formula-based computation over variables in an -`epi_df` over a running window of `n` time steps (see the following `epiprocess` -vignette to go over the basics of the function: ["Slide a computation over -signal values"](https://cmu-delphi.github.io/epiprocess/articles/slide.html)). -The equivalent sliding method for an `epi_archive` object can be called by using -the wrapper function `epix_slide()` (refer to the following vignette for the -basics of the function: ["Work with archive objects and data -revisions"](https://cmu-delphi.github.io/epiprocess/articles/archive.html)). The -key difference from `epi_slide()` is that it performs version-aware -computations. That is, the function only uses data that would have been -available as of time t for that reference time. - -In this vignette, we use `epi_slide()` and `epix_slide()` for backtesting our -`arx_forecaster` on historical COVID-19 case data from the US and from Canada. -More precisely, we first demonstrate using `epi_slide()` to slide ARX -forecasters over an `epi_df` object and compare the results obtained from using -different forecasting engines. We then compare the results from version-aware -and unaware forecasting, where the former is obtained from applying -`epix_slide()` to the `epi_archive` object, while the latter is obtained from -applying `epi_slide()` to the latest snapshot of the data. +A key function from the epiprocess package is `epix_slide()` (refer to the +following vignette for the basics of the function: ["Work with archive objects +and data +revisions"](https://cmu-delphi.github.io/epiprocess/articles/archive.html)) +which allows performing version-aware computations. That is, the function only +uses data that would have been available as of time t for that reference time. + +In this vignette, we use `epix_slide()` for backtesting our `arx_forecaster` on +historical COVID-19 case data from the US and from Canada. We first examine the +results from a version-unaware forecaster, comparing two different fitting +engines and then we contrast this with version-aware forecasting. The former +will proceed by constructing an `epi_archive` that erases its version +information and then use `epix_slide()` to forecast the future. The latter will +keep the versioned data and proceed similarly by using `epix_slide()` to +forecast the future. ## Comparing different forecasting engines @@ -60,16 +54,16 @@ claims and the number of new confirmed COVID-19 cases per 100,000 population Load a data archive -We process as before, with the -modification that we use `sync = locf` in `epix_merge()` so that the last -version of each observation can be carried forward to extrapolate unavailable -versions for the less up-to-date input archive. +We process as before, with the modification that we use `sync = locf` in +`epix_merge()` so that the last version of each observation can be carried +forward to extrapolate unavailable versions for the less up-to-date input +archive. ```{r grab-epi-data} theme_set(theme_bw()) -y <- readRDS("all_states_covidcast_signals.rds") -y <- purrr::map(y, ~ select(.x, geo_value, time_value, version = issue, value)) +y <- readRDS("all_states_covidcast_signals.rds") %>% + purrr::map(~ select(.x, geo_value, time_value, version = issue, value)) x <- epix_merge( y[[1]] %>% rename(percent_cli = value) %>% as_epi_archive(compactify = FALSE), @@ -82,34 +76,36 @@ rm(y)
-After obtaining the latest snapshot of the data, we produce forecasts on that -data using the default engine of simple linear regression and compare to a -random forest. - -Note that all of the warnings about the forecast date being less than the most -recent update date of the data have been suppressed to avoid cluttering the -output. +We then obtaining the latest snapshot of the data and proceed to fake the +version information by setting `version = time_value`. This has the effect of +obtaining data that arrives exactly at the day of the time_value. ```{r arx-kweek-preliminaries, warning = FALSE} # Latest snapshot of data, and forecast dates -x_latest <- epix_as_of(x, version = max(x$versions_end)) -fc_time_values <- seq(from = as.Date("2021-11-01"), to = as.Date("2021-11-01"), by = "1 month") +x_latest <- epix_as_of(x, version = max(x$versions_end)) %>% + mutate(version = time_value) %>% + as_epi_archive() +fc_time_values <- seq( + from = as.Date("2020-08-01"), + to = as.Date("2021-11-01"), + by = "1 month" +) aheads <- c(7, 14, 21, 28) -forecast_k_week_ahead <- function(epi_df, outcome, predictors, ahead = 7, engine) { - epi_slide( - epi_df, - ~ arx_forecaster( - .x, outcome, predictors, engine, - args_list = arx_args_list(ahead = ahead) - )$predictions %>% - select(-geo_value), - .window_size = 120, - .ref_time_values = fc_time_values, - .new_col_name = "fc" - ) %>% - select(geo_value, time_value, starts_with("fc")) %>% - mutate(engine_type = engine$engine) +forecast_k_week_ahead <- function(epi_archive, outcome, predictors, ahead = 7, engine) { + epi_archive %>% + epix_slide( + .f = function(x, gk, rtv) { + arx_forecaster( + x, outcome, predictors, engine, + args_list = arx_args_list(ahead = ahead) + )$predictions %>% + mutate(engine_type = engine$engine) %>% + pivot_quantiles_wider(.pred_distn) + }, + .before = 120, + .versions = fc_time_values + ) } ``` @@ -131,7 +127,6 @@ fc <- bind_rows( engine = rand_forest(mode = "regression") )) ) -pivot_quantiles_wider(fc_.pred_distn) ``` Here, `arx_forecaster()` does all the heavy lifting. It creates leads of the @@ -148,18 +143,22 @@ sense of the model performance while keeping the graphic simple. Code for plotting ```{r plot-arx, message = FALSE, warning = FALSE} -fc_cafl <- fc %>% filter(geo_value %in% c("ca", "fl")) -x_latest_cafl <- x_latest %>% filter(geo_value %in% c("ca", "fl")) - -p1 <- ggplot(fc_cafl, aes(fc_target_date, group = time_value, fill = engine_type)) + +fc_cafl <- fc %>% + tibble() %>% + filter(geo_value %in% c("ca", "fl")) +x_latest_cafl <- x_latest$DT %>% + tibble() %>% + filter(geo_value %in% c("ca", "fl")) + +p1 <- ggplot(fc_cafl, aes(target_date, group = forecast_date, fill = engine_type)) + geom_line( data = x_latest_cafl, aes(x = time_value, y = case_rate), inherit.aes = FALSE, color = "gray50" ) + geom_ribbon(aes(ymin = `0.05`, ymax = `0.95`), alpha = 0.4) + - geom_line(aes(y = fc_.pred)) + - geom_point(aes(y = fc_.pred), size = 0.5) + - geom_vline(aes(xintercept = time_value), linetype = 2, alpha = 0.5) + + geom_line(aes(y = .pred)) + + geom_point(aes(y = .pred), size = 0.5) + + geom_vline(aes(xintercept = forecast_date), linetype = 2, alpha = 0.5) + facet_grid(vars(geo_value), vars(engine_type), scales = "free") + scale_x_date(minor_breaks = "month", date_labels = "%b %y") + scale_fill_brewer(palette = "Set1") + @@ -216,31 +215,30 @@ linear regression with those from using boosted regression trees. can <- readRDS(system.file( "extdata", "can_prov_cases.rds", package = "epipredict", mustWork = TRUE -)) - -can <- can %>% +)) %>% group_by(version, geo_value) %>% arrange(time_value) %>% mutate(cr_7dav = RcppRoll::roll_meanr(case_rate, n = 7L)) %>% as_epi_archive(compactify = TRUE) -can_latest <- epix_as_of(can, max_version = max(can$DT$version)) +can_latest <- epix_as_of(can, version = max(can$DT$version)) %>% + mutate(version = time_value) %>% + as_epi_archive() # Generate the forecasts, and bind them together can_fc <- bind_rows( map( aheads, ~ forecast_k_week_ahead(can_latest, "cr_7dav", "cr_7dav", .x, linear_reg()) - ) %>% list_rbind(), + ), map( aheads, ~ forecast_k_week_ahead( can_latest, "cr_7dav", "cr_7dav", .x, boost_tree(mode = "regression", trees = 20) ) - ) %>% list_rbind() -) %>% - pivot_quantiles_wider(fc_.pred_distn) + ) +) ``` The figures below shows the results for all of the provinces. @@ -248,19 +246,19 @@ The figures below shows the results for all of the provinces. ```{r plot-can-fc-lr, message = FALSE, warning = FALSE, fig.width = 9, fig.height = 12} ggplot( can_fc %>% filter(engine_type == "lm"), - aes(x = fc_target_date, group = time_value) + aes(x = target_date, group = forecast_date) ) + coord_cartesian(xlim = lubridate::ymd(c("2020-12-01", NA))) + geom_line( - data = can_latest, aes(x = time_value, y = cr_7dav), + data = can_latest$DT %>% tibble(), aes(x = time_value, y = cr_7dav), inherit.aes = FALSE, color = "gray50" ) + geom_ribbon(aes(ymin = `0.05`, ymax = `0.95`, fill = geo_value), alpha = 0.4 ) + - geom_line(aes(y = fc_.pred)) + - geom_point(aes(y = fc_.pred), size = 0.5) + - geom_vline(aes(xintercept = time_value), linetype = 2, alpha = 0.5) + + geom_line(aes(y = .pred)) + + geom_point(aes(y = .pred), size = 0.5) + + geom_vline(aes(xintercept = forecast_date), linetype = 2, alpha = 0.5) + facet_wrap(~geo_value, scales = "free_y", ncol = 3) + scale_x_date(minor_breaks = "month", date_labels = "%b %y") + labs( @@ -273,19 +271,19 @@ ggplot( ```{r plot-can-fc-boost, message = FALSE, warning = FALSE, fig.width = 9, fig.height = 12} ggplot( can_fc %>% filter(engine_type == "xgboost"), - aes(x = fc_target_date, group = time_value) + aes(x = target_date, group = forecast_date) ) + coord_cartesian(xlim = lubridate::ymd(c("2020-12-01", NA))) + geom_line( - data = can_latest, aes(x = time_value, y = cr_7dav), + data = can_latest$DT %>% tibble(), aes(x = time_value, y = cr_7dav), inherit.aes = FALSE, color = "gray50" ) + geom_ribbon(aes(ymin = `0.05`, ymax = `0.95`, fill = geo_value), alpha = 0.4 ) + - geom_line(aes(y = fc_.pred)) + - geom_point(aes(y = fc_.pred), size = 0.5) + - geom_vline(aes(xintercept = time_value), linetype = 2, alpha = 0.5) + + geom_line(aes(y = .pred)) + + geom_point(aes(y = .pred), size = 0.5) + + geom_vline(aes(xintercept = forecast_date), linetype = 2, alpha = 0.5) + facet_wrap(~geo_value, scales = "free_y", ncol = 3) + scale_x_date(minor_breaks = "month", date_labels = "%b %y") + labs( @@ -313,9 +311,7 @@ have been available in real-time) to forecast the 7 day average of future COVID-19 case rates from current and past COVID-19 case rates and death rates for all states. That is, we can make forecasts on the archive, `x`, and compare those to forecasts on the latest data, `x_latest` using the same general set-up -as above. For version-aware forecasting, note that `x` is fed into -`epix_slide()`, while for version-unaware forecasting, `x_latest` is fed into -`epi_slide()`. Note that in this example, we use a geo-pooled approach (using +as above. Note that in this example, we use a geo-pooled approach (using combined data from all US states and territories) to train our model.
@@ -352,21 +348,19 @@ deaths_incidence_prop <- pub_covidcast( as_epi_archive(compactify = FALSE) -x <- epix_merge(confirmed_incidence_prop, deaths_incidence_prop, - sync = "locf" -) +x <- epix_merge(confirmed_incidence_prop, deaths_incidence_prop, sync = "locf") x <- x %>% epix_slide( - before = 365000L, ref_time_values = fc_time_values, + .versions = fc_time_values, function(x, gk, rtv) { x %>% group_by(geo_value) %>% - epi_slide_mean(case_rate, before = 6L) %>% + epi_slide_mean(case_rate, .window_size = 7L) %>% rename(case_rate_7d_av = slide_value_case_rate) %>% - epi_slide_mean(death_rate, before = 6L) %>% - ungroup() %>% - rename(death_rate_7d_av = slide_value_death_rate) + epi_slide_mean(death_rate, ..window_size = 7L) %>% + rename(death_rate_7d_av = slide_value_death_rate) %>% + ungroup() } ) %>% rename(version = time_value) %>% @@ -419,14 +413,14 @@ epi archive and store it as `x_latest`. ```{r running-arx-forecaster} arx_preds <- x %>% - epix_slide(~ forecaster(.x), - before = 120, ref_time_values = fc_time_values, - names_sep = NULL + epix_slide( + ~ forecaster(.x), + .before = 120, .versions = fc_time_values ) %>% mutate(engine_type = quantile_reg()$engine) %>% mutate(ahead_val = target_date - forecast_date) -x_latest <- epix_as_of(x, max_version = max(x$versions_end)) +x_latest <- epix_as_of(x, version = max(x$versions_end)) ``` Now we plot both the actual and predicted 7 day average of the death rate for @@ -443,7 +437,7 @@ fc_states <- arx_preds %>% x_latest_states <- x_latest %>% filter(geo_value %in% states_to_show) -p2 <- ggplot(fc_states, aes(target_date, group = time_value)) + +p2 <- ggplot(fc_states, aes(target_date, group = forecast_date)) + geom_ribbon(aes(ymin = `0.05`, ymax = `0.95`, fill = geo_value), alpha = 0.4) + geom_line( data = x_latest_states, aes(x = time_value, y = death_rate_7d_av), @@ -451,7 +445,7 @@ p2 <- ggplot(fc_states, aes(target_date, group = time_value)) + ) + geom_line(aes(y = .pred, color = geo_value)) + geom_point(aes(y = .pred, color = geo_value), size = 0.5) + - geom_vline(aes(xintercept = time_value), linetype = 2, alpha = 0.5) + + geom_vline(aes(xintercept = forecast_date), linetype = 2, alpha = 0.5) + facet_wrap(~geo_value, scales = "free_y", ncol = 1L) + scale_x_date(minor_breaks = "month", date_labels = "%b %y") + scale_fill_brewer(palette = "Set1") + diff --git a/vignettes/articles/smooth-qr.Rmd b/vignettes/articles/smooth-qr.Rmd index 07e237181..3d626b2e1 100644 --- a/vignettes/articles/smooth-qr.Rmd +++ b/vignettes/articles/smooth-qr.Rmd @@ -25,8 +25,8 @@ Whereas other time-series forecasting examples in this package have used epidemiological applications where decisions are based on the trend of a signal. The idea underlying smooth quantile regression is that set forecast targets can -be approximated by a smooth curve. This novel approach from -[Tuzhilina et al., 2022](https://arxiv.org/abs/2202.09723) +be approximated by a smooth curve. This novel approach from +[Tuzhilina et al., 2022](https://arxiv.org/abs/2202.09723) enforces smoothness across the horizons and can be applied to point estimation by regression or interval prediction by quantile regression. Our focus in this vignette is the latter. @@ -62,9 +62,9 @@ The `degree` parameter indicates the degree of the polynomials used for smoothing of the response. It should be no more than the number of aheads. If the degree is precisely equal to the number of aheads, then there is no smoothing. To better understand this parameter and how it works, we should look -to its origins and how it is used in the model. +to its origins and how it is used in the model. -# Model form +# Model form Smooth quantile regression is linear auto-regressive, with the key feature being a transformation that forces the coefficients to satisfy a smoothing constraint. @@ -77,8 +77,8 @@ be no greater than the number of responses. This is a tuning parameter, and so it can be chosen by performing a grid search with cross-validation. Intuitively, $d = 1$ corresponds to the constant model, $d = 2$ gives straight line forecasts, while $d = 3$ gives quadratic forecasts. Since a degree of 3 was -found to work well in the tested applications (see Section 9 of -[Tuzhilina et al., 2022](https://arxiv.org/abs/2202.09723)), +found to work well in the tested applications (see Section 9 of +[Tuzhilina et al., 2022](https://arxiv.org/abs/2202.09723)), it is the default value. # Demonstration of smooth quantile regression @@ -169,7 +169,7 @@ regression, which has three main arguments - the quantiles, aheads, and degree. After creating our `epi_workflow` with these components, we get our test data based on longest lag period and make the predictions. -We input our forecaster into a function for ease of use. +We input our forecaster into a function for ease of use. ```{r} smooth_fc <- function(x, aheads = 1:28, degree = 3L, quantiles = 0.5, fd) { @@ -337,7 +337,8 @@ naturally related over time by a smooth curve. To get the basic quantile regression results we can utilize the forecaster that we've already built. We can simply set the degree to be the number of ahead -values to re-run the code without smoothing. +values to re-run the code without smoothing. + ```{r, warning = FALSE} baseline_preds <- smooth_fc( edf, @@ -397,15 +398,15 @@ that the smooth quantile regression model and baseline models perform very similarly overall, with the smooth quantile regression model only slightly beating the baseline model in terms of overall average MAE. -One other commonly used metric is the Weighted Interval Score -(WIS, [Bracher et al., 2021](https://arxiv.org/pdf/2005.12881.pdf)), +One other commonly used metric is the Weighted Interval Score +(WIS, [Bracher et al., 2021](https://arxiv.org/pdf/2005.12881.pdf)), which a scoring rule that is based on the population quantiles. The point is to score the interval, whereas MAE only evaluates the accuracy of the point forecast. Let $F$ be a forecast composed of predicted quantiles $q_{\tau}$ for the set of quantile levels $\tau$. Then, in terms of the predicted quantiles, the WIS for -target variable $Y$ is represented as follows +target variable $Y$ is represented as follows ([McDonald etal., 2021](https://www.pnas.org/doi/full/10.1073/pnas.2111453118)): $$ @@ -515,5 +516,5 @@ smooth curve. # Attribution -The information presented on smooth quantile regression is from -[Tuzhilina et al., 2022](https://arxiv.org/abs/2202.09723). +The information presented on smooth quantile regression is from +[Tuzhilina et al., 2022](https://arxiv.org/abs/2202.09723). diff --git a/vignettes/articles/symptom-surveys.Rmd b/vignettes/articles/symptom-surveys.Rmd index e8d4a8228..f480db575 100644 --- a/vignettes/articles/symptom-surveys.Rmd +++ b/vignettes/articles/symptom-surveys.Rmd @@ -48,7 +48,7 @@ most recent versions of the datasets). Now, we will delve into the forecasting problem set-up and code followed by a discussion of the results. -## Problem Setup +## Problem Setup Our goal is to predict county-level COVID-19 case incidence rates for 1 and 2 weeks ahead. For this, we restrict our attention to the 442 counties that had at @@ -437,7 +437,7 @@ knitr::kable( format = "html", table.attr = "style='width:70%;'" ) ``` -$$\\[0.01in]$$ +$$\\[0.01in]$$ Are these differences in median scaled errors significant? Some basic hypothesis testing suggests that some probably are: Below we conduct a sign test for whether the difference in the "Cases" model’s scaled error and each other @@ -662,7 +662,7 @@ knitr::kable( format = "html", table.attr = "style='width:70%;'", digits = 3 ) ``` -$$\\[0.01in]$$ +$$\\[0.01in]$$ Thanks to the extended length of the test period, we can also plot the trajectories of the median scaled errors over time, as we do below, with the @@ -731,7 +731,7 @@ knitr::kable( format = "html", table.attr = "style='width:50%;'" ) ``` -$$\\[0.01in]$$ +$$\\[0.01in]$$ If we stratify and recompute p-values by forecast date, the bulk of p-values are quite small. @@ -788,7 +788,7 @@ res <- case_fb_mods(dates, leads) We obtain and plot the median scaled errors for the "Cases" and "Cases + Facebook" models for different number of days ahead for the forecast target. This is done over May 20 through August 27 for the forecast dates that are -common to the two models. +common to the two models. ```{r} err_by_lead <- res %>% @@ -884,4 +884,4 @@ gets pulled "as of" the forecast date (this requires specifying the parameter Hopefully these preliminary findings have gotten you excited about the possible uses of this symptom survey data. For further practice, try your hand at implementing the suggested improvements or develop your own novel analytic -approach to extract insights from this data. +approach to extract insights from this data. From 1caa5490931fc61302d6fd93a64261c89421ea80 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Mon, 30 Sep 2024 12:32:12 -0700 Subject: [PATCH 17/37] error if not an epidf in epirecipe --- NAMESPACE | 1 + R/epi_recipe.R | 24 +++++++++--------------- R/epipredict-package.R | 13 +++++++------ man/epi_recipe.Rd | 2 +- tests/testthat/_snaps/epi_recipe.md | 24 ++++++++++++++++++++++++ tests/testthat/_snaps/epi_workflow.md | 6 +++++- tests/testthat/test-epi_recipe.R | 23 ++++------------------- tests/testthat/test-epi_workflow.R | 2 +- 8 files changed, 52 insertions(+), 43 deletions(-) create mode 100644 tests/testthat/_snaps/epi_recipe.md diff --git a/NAMESPACE b/NAMESPACE index 23c5adeaf..5dea128ac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -272,6 +272,7 @@ 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) diff --git a/R/epi_recipe.R b/R/epi_recipe.R index 88ba605cd..0cc142602 100644 --- a/R/epi_recipe.R +++ b/R/epi_recipe.R @@ -16,15 +16,10 @@ epi_recipe <- function(x, ...) { #' @rdname epi_recipe #' @export epi_recipe.default <- function(x, ...) { - ## if not a formula or an epi_df, we just pass to recipes::recipe - if (is.matrix(x) || is.data.frame(x) || tibble::is_tibble(x)) { - x <- x[1, , drop = FALSE] - } - cli_warn( - "epi_recipe has been called with a non-epi_df object, returning a regular recipe. Various - step_epi_* functions will not work." - ) - recipes::recipe(x, ...) + cli_abort(paste( + "`x` must be an {.cls epi_df} or a {.cls formula},", + "not a {.cls {class(x)[[1]]}}." + )) } #' @rdname epi_recipe @@ -153,16 +148,15 @@ epi_recipe.formula <- function(formula, data, ...) { data <- data[1, ] # check for minus: if (!epiprocess::is_epi_df(data)) { - cli_warn( - "epi_recipe has been called with a non-epi_df object, returning a regular recipe. Various - step_epi_* functions will not work." - ) - return(recipes::recipe(formula, data, ...)) + cli_abort(paste( + "`epi_recipe()` has been called with a non-{.cls epi_df} object.", + "Use `recipe()` instead." + )) } f_funcs <- recipes:::fun_calls(formula, data) if (any(f_funcs == "-")) { - abort("`-` is not allowed in a recipe formula. Use `step_rm()` instead.") + cli_abort("`-` is not allowed in a recipe formula. Use `step_rm()` instead.") } # Check for other in-line functions diff --git a/R/epipredict-package.R b/R/epipredict-package.R index 6460b65e4..733ab9755 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,15 +1,16 @@ ## usethis namespace: start #' @importFrom tibble as_tibble -#' @importFrom rlang := !! %||% as_function global_env set_names !!! -#' is_logical is_true inject enquo enquos expr sym arg_match +#' @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 #' @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 dplyr summarize filter mutate select left_join rename ungroup +#' @importFrom dplyr 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 +#' @importFrom checkmate assert_logical assert_numeric assert_number +#' @importFrom checkmate assert_integer assert_integerish +#' @importFrom checkmate assert_date assert_function assert_class #' @import epiprocess parsnip ## usethis namespace: end NULL diff --git a/man/epi_recipe.Rd b/man/epi_recipe.Rd index d0105d1ec..c31133ab4 100644 --- a/man/epi_recipe.Rd +++ b/man/epi_recipe.Rd @@ -9,7 +9,7 @@ \usage{ epi_recipe(x, ...) -\method{epi_recipe}{default}(x, ...) +\method{epi_recipe}{default}(x, ..., arg = caller_arg(x)) \method{epi_recipe}{epi_df}(x, formula = NULL, ..., vars = NULL, roles = NULL) diff --git a/tests/testthat/_snaps/epi_recipe.md b/tests/testthat/_snaps/epi_recipe.md new file mode 100644 index 000000000..3d797461d --- /dev/null +++ b/tests/testthat/_snaps/epi_recipe.md @@ -0,0 +1,24 @@ +# epi_recipe produces error if not an epi_df + + Code + epi_recipe(tib) + Condition + Error in `epi_recipe()`: + ! `x` must be an or a , not a . + +--- + + Code + epi_recipe(y ~ x, tib) + Condition + Error in `epi_recipe()`: + ! `epi_recipe()` has been called with a non- object. Use `recipe()` instead. + +--- + + Code + epi_recipe(m) + Condition + Error in `epi_recipe()`: + ! `x` must be an or a , not a . + diff --git a/tests/testthat/_snaps/epi_workflow.md b/tests/testthat/_snaps/epi_workflow.md index abd57da2f..d46dad6c1 100644 --- a/tests/testthat/_snaps/epi_workflow.md +++ b/tests/testthat/_snaps/epi_workflow.md @@ -1,6 +1,10 @@ # fit method does not silently drop the class - epi_recipe has been called with a non-epi_df object, returning a regular recipe. Various step_epi_* functions will not work. + Code + epi_recipe(y ~ x, data = tbl) + Condition + Error in `epi_recipe()`: + ! `epi_recipe()` has been called with a non- object. Use `recipe()` instead. --- diff --git a/tests/testthat/test-epi_recipe.R b/tests/testthat/test-epi_recipe.R index ed27d88c0..106c68845 100644 --- a/tests/testthat/test-epi_recipe.R +++ b/tests/testthat/test-epi_recipe.R @@ -1,27 +1,12 @@ -test_that("epi_recipe produces default recipe", { - # these all call recipes::recipe(), but the template will always have 1 row +test_that("epi_recipe produces error if not an epi_df", { tib <- tibble( x = 1:5, y = 1:5, time_value = seq(as.Date("2020-01-01"), by = 1, length.out = 5) ) - expected_rec <- recipes::recipe(tib) - expected_rec$template <- expected_rec$template[1, ] - expect_warning(rec <- epi_recipe(tib), regexp = "epi_recipe has been called with a non-epi_df object") - expect_identical(expected_rec, rec) - expect_equal(nrow(rec$template), 1L) - - expected_rec <- recipes::recipe(y ~ x, tib) - expected_rec$template <- expected_rec$template[1, ] - expect_warning(rec <- epi_recipe(y ~ x, tib), regexp = "epi_recipe has been called with a non-epi_df object") - expect_identical(expected_rec, rec) - expect_equal(nrow(rec$template), 1L) - + expect_snapshot(error = TRUE, epi_recipe(tib)) + expect_snapshot(error = TRUE, epi_recipe(y ~ x, tib)) m <- as.matrix(tib) - expected_rec <- recipes::recipe(m) - expected_rec$template <- expected_rec$template[1, ] - expect_warning(rec <- epi_recipe(m), regexp = "epi_recipe has been called with a non-epi_df object") - expect_identical(expected_rec, rec) - expect_equal(nrow(rec$template), 1L) + expect_snapshot(error = TRUE, epi_recipe(m)) }) test_that("epi_recipe formula works", { diff --git a/tests/testthat/test-epi_workflow.R b/tests/testthat/test-epi_workflow.R index 8236a5885..01eff4209 100644 --- a/tests/testthat/test-epi_workflow.R +++ b/tests/testthat/test-epi_workflow.R @@ -120,7 +120,7 @@ test_that("fit method does not silently drop the class", { rec_tbl <- recipe(y ~ x, data = tbl) rec_edf <- recipe(y ~ x, data = edf) - expect_snapshot_warning(erec_tbl <- epi_recipe(y ~ x, data = tbl)) + expect_snapshot(error = TRUE, epi_recipe(y ~ x, data = tbl)) erec_edf <- epi_recipe(y ~ x, data = edf) ewf_rec_tbl <- epi_workflow(rec_tbl, linear_reg()) From 37d2352446142b55ba0b79590d8a104de8ed0e6e Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 12:34:16 -0700 Subject: [PATCH 18/37] 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 19/37] 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 bffc03be01c450645cfa2ba4be47cb61b46bedf5 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Mon, 30 Sep 2024 12:45:45 -0700 Subject: [PATCH 20/37] redocument --- man/epi_recipe.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/epi_recipe.Rd b/man/epi_recipe.Rd index c31133ab4..d0105d1ec 100644 --- a/man/epi_recipe.Rd +++ b/man/epi_recipe.Rd @@ -9,7 +9,7 @@ \usage{ epi_recipe(x, ...) -\method{epi_recipe}{default}(x, ..., arg = caller_arg(x)) +\method{epi_recipe}{default}(x, ...) \method{epi_recipe}{epi_df}(x, formula = NULL, ..., vars = NULL, roles = NULL) From 65385e2ee2e7fa56a5f7314cae4d422a2691b258 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 12:46:42 -0700 Subject: [PATCH 21/37] 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 addb2ae187442b61450e7476aeb3b8cbbfc64967 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 13:12:29 -0700 Subject: [PATCH 22/37] repo: bump version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7bdc31a6e..7e12a5dc6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: epipredict Title: Basic epidemiology forecasting methods -Version: 0.0.21 +Version: 0.0.23 Authors@R: c( person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"), From 434262ab56727fbb3f5a2d4e73ec40f6d1e1b5ef Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 13:33:20 -0700 Subject: [PATCH 23/37] 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"), From cebc6723270a1e01caf4047852d054cc572f4bfd Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 14:39:06 -0700 Subject: [PATCH 24/37] repo: fix imports and remove unused standalone files --- DESCRIPTION | 1 + NAMESPACE | 12 - R/epipredict-package.R | 10 +- R/import-standalone-lifecycle.R | 254 -------------- R/import-standalone-obj-type.R | 363 -------------------- R/import-standalone-types-check.R | 553 ------------------------------ R/pivot_quantiles.R | 2 +- man/autoplot-epipred.Rd | 2 - 8 files changed, 7 insertions(+), 1190 deletions(-) delete mode 100644 R/import-standalone-lifecycle.R delete mode 100644 R/import-standalone-obj-type.R delete mode 100644 R/import-standalone-types-check.R diff --git a/DESCRIPTION b/DESCRIPTION index 26093014c..c76280d45 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,6 +35,7 @@ Imports: ggplot2, glue, hardhat (>= 1.3.0), + lifecycle, magrittr, recipes (>= 1.0.4), rlang (>= 1.1.0), diff --git a/NAMESPACE b/NAMESPACE index ea516dbde..e815203eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -273,24 +273,12 @@ importFrom(rlang,caller_arg) importFrom(rlang,caller_env) importFrom(rlang,enquo) importFrom(rlang,enquos) -importFrom(rlang,env_get_list) importFrom(rlang,expr) importFrom(rlang,global_env) importFrom(rlang,inject) -importFrom(rlang,is_call) -importFrom(rlang,is_character) -importFrom(rlang,is_closure) -importFrom(rlang,is_environment) -importFrom(rlang,is_formula) -importFrom(rlang,is_function) -importFrom(rlang,is_list) importFrom(rlang,is_logical) -importFrom(rlang,is_missing) importFrom(rlang,is_null) -importFrom(rlang,is_string) -importFrom(rlang,is_symbol) importFrom(rlang,is_true) -importFrom(rlang,is_vector) importFrom(rlang,set_names) importFrom(rlang,sym) importFrom(stats,as.formula) diff --git a/R/epipredict-package.R b/R/epipredict-package.R index adde4967d..ad0f95295 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,13 +1,13 @@ ## usethis namespace: start #' @import epiprocess parsnip -#' @importFrom checkmate assert assert_character assert_int assert_scalar -#' @importFrom checkmate assert_logical assert_numeric assert_number -#' @importFrom checkmate assert_integer assert_integerish -#' @importFrom checkmate assert_date assert_function assert_class +#' @importFrom checkmate assert_class assert_numeric +#' @importFrom checkmate test_character test_date test_function +#' @importFrom checkmate test_integerish test_logical +#' @importFrom checkmate test_numeric test_scalar #' @importFrom cli cli_abort cli_warn #' @importFrom dplyr arrange across all_of any_of bind_cols bind_rows group_by -#' @importFrom dplyr summarize filter mutate select left_join rename ungroup #' @importFrom dplyr full_join relocate summarise everything +#' @importFrom dplyr summarize filter mutate select left_join rename ungroup #' @importFrom rlang := !! %||% as_function global_env set_names !!! caller_arg #' @importFrom rlang is_logical is_true inject enquo enquos expr sym arg_match #' @importFrom stats poly predict lm residuals quantile diff --git a/R/import-standalone-lifecycle.R b/R/import-standalone-lifecycle.R deleted file mode 100644 index a1be17134..000000000 --- a/R/import-standalone-lifecycle.R +++ /dev/null @@ -1,254 +0,0 @@ -# Standalone file: do not edit by hand -# Source: -# ---------------------------------------------------------------------- -# -# --- -# repo: r-lib/rlang -# file: standalone-lifecycle.R -# last-updated: 2023-02-23 -# license: https://unlicense.org -# imports: rlang (>= 1.0.0) -# --- -# -# This file serves as a reference for currently unexported rlang -# lifecycle functions. These functions require rlang in your `Imports` -# DESCRIPTION field but you don't need to import rlang in your -# namespace. -# -# ## Changelog -# -# 2023-02-23 -# -# - Updated the API and internals to match modern lifecycle tools. -# -# -# 2021-04-19 -# -# - Removed `lifecycle()` function. You can now use the following in -# your roxygen documentation to inline a badge: -# -# ``` -# `r lifecycle::badge()` -# ``` -# -# This is a build-time dependency on lifecycle so there is no need -# to add lifecycle to Imports just to use badges. See also -# `?usethis::use_lifecycle()` for importing or updating the badge -# images in your package. -# -# - Soft-namespaced private objects. -# -# nocov start - - -#' Signal deprecation -#' -#' @description -#' These functions provide two levels of verbosity for deprecation -#' warnings. -#' -#' * `deprecate_soft()` warns only if called directly: from the global -#' environment (so the user can change their script) or from the -#' package currently being tested (so the package developer can fix -#' the package). -#' -#' * `deprecate_warn()` warns unconditionally. -#' -#' * `deprecate_stop()` fails unconditionally. -#' -#' Both functions warn only once per session by default to avoid -#' overwhelming the user with repeated warnings. -#' -#' @param msg The deprecation message. -#' @param id The id of the deprecation. A warning is issued only once -#' for each `id`. Defaults to `msg`, but you should give a unique ID -#' when the message is built programmatically and depends on inputs. -#' @param user_env The environment in which the deprecated function -#' was called. The verbosity depends on whether the deprecated -#' feature was called directly, see [rlang::env_is_user_facing()] and the -#' documentation in the lifecycle package. -#' -#' @section Controlling verbosity: -#' -#' The verbosity of retirement warnings can be controlled with global -#' options. You'll generally want to set these options locally with -#' one of these helpers: -#' -#' * `with_lifecycle_silence()` disables all soft-deprecation and -#' deprecation warnings. -#' -#' * `with_lifecycle_warnings()` enforces warnings for both -#' soft-deprecated and deprecated functions. The warnings are -#' repeated rather than signalled once per session. -#' -#' * `with_lifecycle_errors()` enforces errors for both -#' soft-deprecated and deprecated functions. -#' -#' All the `with_` helpers have `scoped_` variants that are -#' particularly useful in testthat blocks. -#' -#' @noRd -NULL - -deprecate_soft <- function(msg, - id = msg, - user_env = rlang::caller_env(2)) { - .rlang_lifecycle_signal_stage(msg, "deprecated") - - id <- paste(id, collapse = "\n") - verbosity <- .rlang_lifecycle_verbosity() - - invisible(switch( - verbosity, - quiet = NULL, - warning = , - default = - if (rlang::env_is_user_facing(user_env)) { - always <- verbosity == "warning" - trace <- rlang::trace_back(bottom = caller_env()) - .rlang_lifecycle_deprecate_warn0( - msg, - id = id, - trace = trace, - always = always - ) - }, - error = deprecate_stop(msg) - )) -} - -deprecate_warn <- function(msg, - id = msg, - always = FALSE, - user_env = rlang::caller_env(2)) { - .rlang_lifecycle_signal_stage(msg, "deprecated") - - id <- paste(id, collapse = "\n") - verbosity <- .rlang_lifecycle_verbosity() - - invisible(switch( - verbosity, - quiet = NULL, - warning = , - default = { - direct <- rlang::env_is_user_facing(user_env) - always <- direct && (always || verbosity == "warning") - - trace <- tryCatch( - rlang::trace_back(bottom = rlang::caller_env()), - error = function(...) NULL - ) - - .rlang_lifecycle_deprecate_warn0( - msg, - id = id, - trace = trace, - always = always - ) - }, - error = deprecate_stop(msg), - )) -} - -.rlang_lifecycle_deprecate_warn0 <- function(msg, - id = msg, - trace = NULL, - always = FALSE, - call = rlang::caller_env()) { - if (always) { - freq <- "always" - } else { - freq <- "regularly" - } - - rlang::warn( - msg, - class = "lifecycle_warning_deprecated", - .frequency = freq, - .frequency_id = id - ) -} - -deprecate_stop <- function(msg) { - msg <- cli::format_error(msg) - .rlang_lifecycle_signal_stage(msg, "deprecated") - - stop(rlang::cnd( - c("defunctError", "error", "condition"), - old = NULL, - new = NULL, - package = NULL, - message = msg - )) -} - -.rlang_lifecycle_signal_stage <- function(msg, stage) { - rlang::signal(msg, "lifecycle_stage", stage = stage) -} - -expect_deprecated <- function(expr, regexp = NULL, ...) { - rlang::local_options(lifecycle_verbosity = "warning") - - if (!is.null(regexp) && rlang::is_na(regexp)) { - rlang::abort("`regexp` can't be `NA`.") - } - - testthat::expect_warning( - {{ expr }}, - regexp = regexp, - class = "lifecycle_warning_deprecated", - ... - ) -} - -local_lifecycle_silence <- function(frame = rlang::caller_env()) { - rlang::local_options( - .frame = frame, - lifecycle_verbosity = "quiet" - ) -} -with_lifecycle_silence <- function(expr) { - local_lifecycle_silence() - expr -} - -local_lifecycle_warnings <- function(frame = rlang::caller_env()) { - rlang::local_options( - .frame = frame, - lifecycle_verbosity = "warning" - ) -} -with_lifecycle_warnings <- function(expr) { - local_lifecycle_warnings() - expr -} - -local_lifecycle_errors <- function(frame = rlang::caller_env()) { - rlang::local_options( - .frame = frame, - lifecycle_verbosity = "error" - ) -} -with_lifecycle_errors <- function(expr) { - local_lifecycle_errors() - expr -} - -.rlang_lifecycle_verbosity <- function() { - opt <- getOption("lifecycle_verbosity", "default") - - if (!rlang::is_string(opt, c("quiet", "default", "warning", "error"))) { - options(lifecycle_verbosity = "default") - rlang::warn(glue::glue( - " - The `lifecycle_verbosity` option must be set to one of: - \"quiet\", \"default\", \"warning\", or \"error\". - Resetting to \"default\". - " - )) - } - - opt -} - -# nocov end diff --git a/R/import-standalone-obj-type.R b/R/import-standalone-obj-type.R deleted file mode 100644 index 646aa33fc..000000000 --- a/R/import-standalone-obj-type.R +++ /dev/null @@ -1,363 +0,0 @@ -# Standalone file: do not edit by hand -# Source: -# ---------------------------------------------------------------------- -# -# --- -# repo: r-lib/rlang -# file: standalone-obj-type.R -# last-updated: 2024-02-14 -# license: https://unlicense.org -# imports: rlang (>= 1.1.0) -# --- -# -# ## Changelog -# -# 2024-02-14: -# - `obj_type_friendly()` now works for S7 objects. -# -# 2023-05-01: -# - `obj_type_friendly()` now only displays the first class of S3 objects. -# -# 2023-03-30: -# - `stop_input_type()` now handles `I()` input literally in `arg`. -# -# 2022-10-04: -# - `obj_type_friendly(value = TRUE)` now shows numeric scalars -# literally. -# - `stop_friendly_type()` now takes `show_value`, passed to -# `obj_type_friendly()` as the `value` argument. -# -# 2022-10-03: -# - Added `allow_na` and `allow_null` arguments. -# - `NULL` is now backticked. -# - Better friendly type for infinities and `NaN`. -# -# 2022-09-16: -# - Unprefixed usage of rlang functions with `rlang::` to -# avoid onLoad issues when called from rlang (#1482). -# -# 2022-08-11: -# - Prefixed usage of rlang functions with `rlang::`. -# -# 2022-06-22: -# - `friendly_type_of()` is now `obj_type_friendly()`. -# - Added `obj_type_oo()`. -# -# 2021-12-20: -# - Added support for scalar values and empty vectors. -# - Added `stop_input_type()` -# -# 2021-06-30: -# - Added support for missing arguments. -# -# 2021-04-19: -# - Added support for matrices and arrays (#141). -# - Added documentation. -# - Added changelog. -# -# nocov start - -#' Return English-friendly type -#' @param x Any R object. -#' @param value Whether to describe the value of `x`. Special values -#' like `NA` or `""` are always described. -#' @param length Whether to mention the length of vectors and lists. -#' @return A string describing the type. Starts with an indefinite -#' article, e.g. "an integer vector". -#' @noRd -obj_type_friendly <- function(x, value = TRUE) { - if (is_missing(x)) { - return("absent") - } - - if (is.object(x)) { - if (inherits(x, "quosure")) { - type <- "quosure" - } else { - type <- class(x)[[1L]] - } - return(sprintf("a <%s> object", type)) - } - - if (!is_vector(x)) { - return(.rlang_as_friendly_type(typeof(x))) - } - - n_dim <- length(dim(x)) - - if (!n_dim) { - if (!is_list(x) && length(x) == 1) { - if (is_na(x)) { - return(switch( - typeof(x), - logical = "`NA`", - integer = "an integer `NA`", - double = - if (is.nan(x)) { - "`NaN`" - } else { - "a numeric `NA`" - }, - complex = "a complex `NA`", - character = "a character `NA`", - .rlang_stop_unexpected_typeof(x) - )) - } - - show_infinites <- function(x) { - if (x > 0) { - "`Inf`" - } else { - "`-Inf`" - } - } - str_encode <- function(x, width = 30, ...) { - if (nchar(x) > width) { - x <- substr(x, 1, width - 3) - x <- paste0(x, "...") - } - encodeString(x, ...) - } - - if (value) { - if (is.numeric(x) && is.infinite(x)) { - return(show_infinites(x)) - } - - if (is.numeric(x) || is.complex(x)) { - number <- as.character(round(x, 2)) - what <- if (is.complex(x)) "the complex number" else "the number" - return(paste(what, number)) - } - - return(switch( - typeof(x), - logical = if (x) "`TRUE`" else "`FALSE`", - character = { - what <- if (nzchar(x)) "the string" else "the empty string" - paste(what, str_encode(x, quote = "\"")) - }, - raw = paste("the raw value", as.character(x)), - .rlang_stop_unexpected_typeof(x) - )) - } - - return(switch( - typeof(x), - logical = "a logical value", - integer = "an integer", - double = if (is.infinite(x)) show_infinites(x) else "a number", - complex = "a complex number", - character = if (nzchar(x)) "a string" else "\"\"", - raw = "a raw value", - .rlang_stop_unexpected_typeof(x) - )) - } - - if (length(x) == 0) { - return(switch( - typeof(x), - logical = "an empty logical vector", - integer = "an empty integer vector", - double = "an empty numeric vector", - complex = "an empty complex vector", - character = "an empty character vector", - raw = "an empty raw vector", - list = "an empty list", - .rlang_stop_unexpected_typeof(x) - )) - } - } - - vec_type_friendly(x) -} - -vec_type_friendly <- function(x, length = FALSE) { - if (!is_vector(x)) { - abort("`x` must be a vector.") - } - type <- typeof(x) - n_dim <- length(dim(x)) - - add_length <- function(type) { - if (length && !n_dim) { - paste0(type, sprintf(" of length %s", length(x))) - } else { - type - } - } - - if (type == "list") { - if (n_dim < 2) { - return(add_length("a list")) - } else if (is.data.frame(x)) { - return("a data frame") - } else if (n_dim == 2) { - return("a list matrix") - } else { - return("a list array") - } - } - - type <- switch( - type, - logical = "a logical %s", - integer = "an integer %s", - numeric = , - double = "a double %s", - complex = "a complex %s", - character = "a character %s", - raw = "a raw %s", - type = paste0("a ", type, " %s") - ) - - if (n_dim < 2) { - kind <- "vector" - } else if (n_dim == 2) { - kind <- "matrix" - } else { - kind <- "array" - } - out <- sprintf(type, kind) - - if (n_dim >= 2) { - out - } else { - add_length(out) - } -} - -.rlang_as_friendly_type <- function(type) { - switch( - type, - - list = "a list", - - NULL = "`NULL`", - environment = "an environment", - externalptr = "a pointer", - weakref = "a weak reference", - S4 = "an S4 object", - - name = , - symbol = "a symbol", - language = "a call", - pairlist = "a pairlist node", - expression = "an expression vector", - - char = "an internal string", - promise = "an internal promise", - ... = "an internal dots object", - any = "an internal `any` object", - bytecode = "an internal bytecode object", - - primitive = , - builtin = , - special = "a primitive function", - closure = "a function", - - type - ) -} - -.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) { - abort( - sprintf("Unexpected type <%s>.", typeof(x)), - call = call - ) -} - -#' Return OO type -#' @param x Any R object. -#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, -#' `"R6"`, or `"S7"`. -#' @noRd -obj_type_oo <- function(x) { - if (!is.object(x)) { - return("bare") - } - - class <- inherits(x, c("R6", "S7_object"), which = TRUE) - - if (class[[1]]) { - "R6" - } else if (class[[2]]) { - "S7" - } else if (isS4(x)) { - "S4" - } else { - "S3" - } -} - -#' @param x The object type which does not conform to `what`. Its -#' `obj_type_friendly()` is taken and mentioned in the error message. -#' @param what The friendly expected type as a string. Can be a -#' character vector of expected types, in which case the error -#' message mentions all of them in an "or" enumeration. -#' @param show_value Passed to `value` argument of `obj_type_friendly()`. -#' @param ... Arguments passed to [abort()]. -#' @inheritParams args_error_context -#' @noRd -stop_input_type <- function(x, - what, - ..., - allow_na = FALSE, - allow_null = FALSE, - show_value = TRUE, - arg = caller_arg(x), - call = caller_env()) { - # From standalone-cli.R - cli <- env_get_list( - nms = c("format_arg", "format_code"), - last = topenv(), - default = function(x) sprintf("`%s`", x), - inherit = TRUE - ) - - if (allow_na) { - what <- c(what, cli$format_code("NA")) - } - if (allow_null) { - what <- c(what, cli$format_code("NULL")) - } - if (length(what)) { - what <- oxford_comma(what) - } - if (inherits(arg, "AsIs")) { - format_arg <- identity - } else { - format_arg <- cli$format_arg - } - - message <- sprintf( - "%s must be %s, not %s.", - format_arg(arg), - what, - obj_type_friendly(x, value = show_value) - ) - - abort(message, ..., call = call, arg = arg) -} - -oxford_comma <- function(chr, sep = ", ", final = "or") { - n <- length(chr) - - if (n < 2) { - return(chr) - } - - head <- chr[seq_len(n - 1)] - last <- chr[n] - - head <- paste(head, collapse = sep) - - # Write a or b. But a, b, or c. - if (n > 2) { - paste0(head, sep, final, " ", last) - } else { - paste0(head, " ", final, " ", last) - } -} - -# nocov end diff --git a/R/import-standalone-types-check.R b/R/import-standalone-types-check.R deleted file mode 100644 index 1ca83997d..000000000 --- a/R/import-standalone-types-check.R +++ /dev/null @@ -1,553 +0,0 @@ -# Standalone file: do not edit by hand -# Source: -# ---------------------------------------------------------------------- -# -# --- -# repo: r-lib/rlang -# file: standalone-types-check.R -# last-updated: 2023-03-13 -# license: https://unlicense.org -# dependencies: standalone-obj-type.R -# imports: rlang (>= 1.1.0) -# --- -# -# ## Changelog -# -# 2024-08-15: -# - `check_character()` gains an `allow_na` argument (@martaalcalde, #1724) -# -# 2023-03-13: -# - Improved error messages of number checkers (@teunbrand) -# - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich). -# - Added `check_data_frame()` (@mgirlich). -# -# 2023-03-07: -# - Added dependency on rlang (>= 1.1.0). -# -# 2023-02-15: -# - Added `check_logical()`. -# -# - `check_bool()`, `check_number_whole()`, and -# `check_number_decimal()` are now implemented in C. -# -# - For efficiency, `check_number_whole()` and -# `check_number_decimal()` now take a `NULL` default for `min` and -# `max`. This makes it possible to bypass unnecessary type-checking -# and comparisons in the default case of no bounds checks. -# -# 2022-10-07: -# - `check_number_whole()` and `_decimal()` no longer treat -# non-numeric types such as factors or dates as numbers. Numeric -# types are detected with `is.numeric()`. -# -# 2022-10-04: -# - Added `check_name()` that forbids the empty string. -# `check_string()` allows the empty string by default. -# -# 2022-09-28: -# - Removed `what` arguments. -# - Added `allow_na` and `allow_null` arguments. -# - Added `allow_decimal` and `allow_infinite` arguments. -# - Improved errors with absent arguments. -# -# -# 2022-09-16: -# - Unprefixed usage of rlang functions with `rlang::` to -# avoid onLoad issues when called from rlang (#1482). -# -# 2022-08-11: -# - Added changelog. -# -# nocov start - -# Scalars ----------------------------------------------------------------- - -.standalone_types_check_dot_call <- .Call - -check_bool <- function(x, - ..., - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x) && .standalone_types_check_dot_call(ffi_standalone_is_bool_1.0.7, x, allow_na, allow_null)) { - return(invisible(NULL)) - } - - stop_input_type( - x, - c("`TRUE`", "`FALSE`"), - ..., - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_string <- function(x, - ..., - allow_empty = TRUE, - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - is_string <- .rlang_check_is_string( - x, - allow_empty = allow_empty, - allow_na = allow_na, - allow_null = allow_null - ) - if (is_string) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a single string", - ..., - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -.rlang_check_is_string <- function(x, - allow_empty, - allow_na, - allow_null) { - if (is_string(x)) { - if (allow_empty || !is_string(x, "")) { - return(TRUE) - } - } - - if (allow_null && is_null(x)) { - return(TRUE) - } - - if (allow_na && (identical(x, NA) || identical(x, na_chr))) { - return(TRUE) - } - - FALSE -} - -check_name <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - is_string <- .rlang_check_is_string( - x, - allow_empty = FALSE, - allow_na = FALSE, - allow_null = allow_null - ) - if (is_string) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a valid name", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -IS_NUMBER_true <- 0 -IS_NUMBER_false <- 1 -IS_NUMBER_oob <- 2 - -check_number_decimal <- function(x, - ..., - min = NULL, - max = NULL, - allow_infinite = TRUE, - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (missing(x)) { - exit_code <- IS_NUMBER_false - } else if (0 == (exit_code <- .standalone_types_check_dot_call( - ffi_standalone_check_number_1.0.7, - x, - allow_decimal = TRUE, - min, - max, - allow_infinite, - allow_na, - allow_null - ))) { - return(invisible(NULL)) - } - - .stop_not_number( - x, - ..., - exit_code = exit_code, - allow_decimal = TRUE, - min = min, - max = max, - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_number_whole <- function(x, - ..., - min = NULL, - max = NULL, - allow_infinite = FALSE, - allow_na = FALSE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (missing(x)) { - exit_code <- IS_NUMBER_false - } else if (0 == (exit_code <- .standalone_types_check_dot_call( - ffi_standalone_check_number_1.0.7, - x, - allow_decimal = FALSE, - min, - max, - allow_infinite, - allow_na, - allow_null - ))) { - return(invisible(NULL)) - } - - .stop_not_number( - x, - ..., - exit_code = exit_code, - allow_decimal = FALSE, - min = min, - max = max, - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -.stop_not_number <- function(x, - ..., - exit_code, - allow_decimal, - min, - max, - allow_na, - allow_null, - arg, - call) { - if (allow_decimal) { - what <- "a number" - } else { - what <- "a whole number" - } - - if (exit_code == IS_NUMBER_oob) { - min <- min %||% -Inf - max <- max %||% Inf - - if (min > -Inf && max < Inf) { - what <- sprintf("%s between %s and %s", what, min, max) - } else if (x < min) { - what <- sprintf("%s larger than or equal to %s", what, min) - } else if (x > max) { - what <- sprintf("%s smaller than or equal to %s", what, max) - } else { - abort("Unexpected state in OOB check", .internal = TRUE) - } - } - - stop_input_type( - x, - what, - ..., - allow_na = allow_na, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_symbol <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_symbol(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a symbol", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_arg <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_symbol(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "an argument name", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_call <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_call(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a defused call", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_environment <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_environment(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "an environment", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_function <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_function(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a function", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_closure <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_closure(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "an R function", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_formula <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_formula(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a formula", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - - -# Vectors ----------------------------------------------------------------- - -# TODO: Figure out what to do with logical `NA` and `allow_na = TRUE` - -check_character <- function(x, - ..., - allow_na = TRUE, - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - - if (!missing(x)) { - if (is_character(x)) { - if (!allow_na && any(is.na(x))) { - abort( - sprintf("`%s` can't contain NA values.", arg), - arg = arg, - call = call - ) - } - - return(invisible(NULL)) - } - - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a character vector", - ..., - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_logical <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is_logical(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a logical vector", - ..., - allow_na = FALSE, - allow_null = allow_null, - arg = arg, - call = call - ) -} - -check_data_frame <- function(x, - ..., - allow_null = FALSE, - arg = caller_arg(x), - call = caller_env()) { - if (!missing(x)) { - if (is.data.frame(x)) { - return(invisible(NULL)) - } - if (allow_null && is_null(x)) { - return(invisible(NULL)) - } - } - - stop_input_type( - x, - "a data frame", - ..., - allow_null = allow_null, - arg = arg, - call = call - ) -} - -# nocov end diff --git a/R/pivot_quantiles.R b/R/pivot_quantiles.R index c8601b4f6..f014961e6 100644 --- a/R/pivot_quantiles.R +++ b/R/pivot_quantiles.R @@ -148,7 +148,7 @@ pivot_quantiles <- function(.data, ...) { "{.fn pivot_quantiles} was deprecated in {.pkg epipredict} 0.0.6", i = "Please use {.fn pivot_quantiles_wider} instead." ) - deprecate_stop(msg) + lifecycle::deprecate_stop(msg) } validate_pivot_quantiles <- function(.data, ...) { diff --git a/man/autoplot-epipred.Rd b/man/autoplot-epipred.Rd index 10236eb98..27bfdf5f7 100644 --- a/man/autoplot-epipred.Rd +++ b/man/autoplot-epipred.Rd @@ -121,6 +121,4 @@ arx <- arx_forecaster(jhu, "death_rate", c("case_rate", "death_rate"), args_list = arx_args_list(ahead = 14L) ) autoplot(arx, .max_facets = 6) -NULL - } From f588f0a28f9bcac1612bd7fc3e7016e5fd28ec71 Mon Sep 17 00:00:00 2001 From: Dmitry Shemetov Date: Mon, 30 Sep 2024 13:37:51 -0700 Subject: [PATCH 25/37] tests: snapshot tests on errors --- NAMESPACE | 12 -- R/epipredict-package.R | 8 +- man/autoplot-epipred.Rd | 2 - tests/testthat/_snaps/arx_args_list.md | 152 ++++++++++++++++++ tests/testthat/_snaps/arx_cargs_list.md | 92 +++++++++++ tests/testthat/_snaps/bake-method.md | 9 ++ tests/testthat/_snaps/check-training-set.md | 20 +++ .../_snaps/check_enough_train_data.md | 46 ++++++ tests/testthat/_snaps/dist_quantiles.md | 56 +++++++ tests/testthat/_snaps/enframer.md | 32 ++++ tests/testthat/_snaps/epi_recipe.md | 8 + tests/testthat/_snaps/epi_workflow.md | 17 ++ tests/testthat/_snaps/extract_argument.md | 72 +++++++++ tests/testthat/_snaps/flatline_args_list.md | 128 +++++++++++++++ tests/testthat/_snaps/frosting.md | 16 ++ tests/testthat/_snaps/get_test_data.md | 66 ++++++++ .../_snaps/layer_add_forecast_date.md | 42 +++++ .../testthat/_snaps/layer_add_target_date.md | 8 + tests/testthat/_snaps/layer_predict.md | 8 + .../_snaps/layer_residual_quantiles.md | 18 +++ tests/testthat/_snaps/layers.md | 24 +++ tests/testthat/_snaps/parse_period.md | 32 ++++ .../_snaps/parsnip_model_validation.md | 18 +++ tests/testthat/_snaps/pivot_quantiles.md | 51 ++++++ tests/testthat/_snaps/population_scaling.md | 16 ++ tests/testthat/_snaps/shuffle.md | 8 + tests/testthat/_snaps/step_epi_slide.md | 16 ++ tests/testthat/_snaps/wis-dist-quantiles.md | 17 ++ tests/testthat/test-arx_args_list.R | 36 ++--- tests/testthat/test-arx_cargs_list.R | 22 +-- tests/testthat/test-bake-method.R | 2 +- tests/testthat/test-check-training-set.R | 4 +- tests/testthat/test-check_enough_train_data.R | 21 +-- tests/testthat/test-dist_quantiles.R | 14 +- tests/testthat/test-enframer.R | 8 +- tests/testthat/test-epi_recipe.R | 2 +- tests/testthat/test-epi_workflow.R | 4 +- tests/testthat/test-extract_argument.R | 18 +-- tests/testthat/test-flatline_args_list.R | 30 ++-- tests/testthat/test-frosting.R | 4 +- tests/testthat/test-get_test_data.R | 16 +- tests/testthat/test-layer_add_forecast_date.R | 10 +- tests/testthat/test-layer_add_target_date.R | 2 +- tests/testthat/test-layer_predict.R | 2 +- .../testthat/test-layer_residual_quantiles.R | 8 +- tests/testthat/test-layers.R | 6 +- tests/testthat/test-parse_period.R | 8 +- .../testthat/test-parsnip_model_validation.R | 4 +- tests/testthat/test-pivot_quantiles.R | 12 +- tests/testthat/test-population_scaling.R | 5 +- tests/testthat/test-shuffle.R | 2 +- tests/testthat/test-step_epi_slide.R | 2 + tests/testthat/test-wis-dist-quantiles.R | 4 +- 53 files changed, 1102 insertions(+), 138 deletions(-) create mode 100644 tests/testthat/_snaps/arx_args_list.md create mode 100644 tests/testthat/_snaps/arx_cargs_list.md create mode 100644 tests/testthat/_snaps/bake-method.md create mode 100644 tests/testthat/_snaps/check-training-set.md create mode 100644 tests/testthat/_snaps/check_enough_train_data.md create mode 100644 tests/testthat/_snaps/dist_quantiles.md create mode 100644 tests/testthat/_snaps/enframer.md create mode 100644 tests/testthat/_snaps/extract_argument.md create mode 100644 tests/testthat/_snaps/flatline_args_list.md create mode 100644 tests/testthat/_snaps/frosting.md create mode 100644 tests/testthat/_snaps/get_test_data.md create mode 100644 tests/testthat/_snaps/layer_add_forecast_date.md create mode 100644 tests/testthat/_snaps/layer_add_target_date.md create mode 100644 tests/testthat/_snaps/layer_predict.md create mode 100644 tests/testthat/_snaps/layer_residual_quantiles.md create mode 100644 tests/testthat/_snaps/layers.md create mode 100644 tests/testthat/_snaps/parse_period.md create mode 100644 tests/testthat/_snaps/parsnip_model_validation.md create mode 100644 tests/testthat/_snaps/pivot_quantiles.md create mode 100644 tests/testthat/_snaps/population_scaling.md create mode 100644 tests/testthat/_snaps/shuffle.md create mode 100644 tests/testthat/_snaps/wis-dist-quantiles.md diff --git a/NAMESPACE b/NAMESPACE index ea516dbde..e815203eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -273,24 +273,12 @@ importFrom(rlang,caller_arg) importFrom(rlang,caller_env) importFrom(rlang,enquo) importFrom(rlang,enquos) -importFrom(rlang,env_get_list) importFrom(rlang,expr) importFrom(rlang,global_env) importFrom(rlang,inject) -importFrom(rlang,is_call) -importFrom(rlang,is_character) -importFrom(rlang,is_closure) -importFrom(rlang,is_environment) -importFrom(rlang,is_formula) -importFrom(rlang,is_function) -importFrom(rlang,is_list) importFrom(rlang,is_logical) -importFrom(rlang,is_missing) importFrom(rlang,is_null) -importFrom(rlang,is_string) -importFrom(rlang,is_symbol) importFrom(rlang,is_true) -importFrom(rlang,is_vector) importFrom(rlang,set_names) importFrom(rlang,sym) importFrom(stats,as.formula) diff --git a/R/epipredict-package.R b/R/epipredict-package.R index adde4967d..b6550c6b4 100644 --- a/R/epipredict-package.R +++ b/R/epipredict-package.R @@ -1,9 +1,9 @@ ## usethis namespace: start #' @import epiprocess parsnip -#' @importFrom checkmate assert assert_character assert_int assert_scalar -#' @importFrom checkmate assert_logical assert_numeric assert_number -#' @importFrom checkmate assert_integer assert_integerish -#' @importFrom checkmate assert_date assert_function assert_class +#' @importFrom checkmate assert_class assert_numeric +#' @importFrom checkmate test_character test_date test_function +#' @importFrom checkmate test_integerish test_logical +#' @importFrom checkmate test_numeric test_scalar #' @importFrom cli cli_abort cli_warn #' @importFrom dplyr arrange across all_of any_of bind_cols bind_rows group_by #' @importFrom dplyr summarize filter mutate select left_join rename ungroup diff --git a/man/autoplot-epipred.Rd b/man/autoplot-epipred.Rd index 10236eb98..27bfdf5f7 100644 --- a/man/autoplot-epipred.Rd +++ b/man/autoplot-epipred.Rd @@ -121,6 +121,4 @@ arx <- arx_forecaster(jhu, "death_rate", c("case_rate", "death_rate"), args_list = arx_args_list(ahead = 14L) ) autoplot(arx, .max_facets = 6) -NULL - } diff --git a/tests/testthat/_snaps/arx_args_list.md b/tests/testthat/_snaps/arx_args_list.md new file mode 100644 index 000000000..959a5e25b --- /dev/null +++ b/tests/testthat/_snaps/arx_args_list.md @@ -0,0 +1,152 @@ +# arx_args checks inputs + + Code + arx_args_list(ahead = c(0, 4)) + Condition + Error in `arx_args_list()`: + ! `ahead` must be a scalar. + +--- + + Code + arx_args_list(n_training = c(28, 65)) + Condition + Error in `arx_args_list()`: + ! `n_training` must be a scalar. + +--- + + Code + arx_args_list(ahead = -1) + Condition + Error in `arx_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_args_list(ahead = 1.5) + Condition + Error in `arx_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_args_list(n_training = -1) + Condition + Error in `arx_args_list()`: + ! `n_training` must be a strictly positive number. + +--- + + Code + arx_args_list(n_training = 1.5) + Condition + Error in `arx_args_list()`: + ! `n_training` must be a positive integer. + +--- + + Code + arx_args_list(lags = c(-1, 0)) + Condition + Error in `arx_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_args_list(lags = list(c(1:5, 6.5), 2:8)) + Condition + Error in `arx_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_args_list(symmetrize = 4) + Condition + Error in `arx_args_list()`: + ! `symmetrize` must be of type . + +--- + + Code + arx_args_list(nonneg = 4) + Condition + Error in `arx_args_list()`: + ! `nonneg` must be of type . + +--- + + Code + arx_args_list(quantile_levels = -0.1) + Condition + Error in `arx_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + arx_args_list(quantile_levels = 1.1) + Condition + Error in `arx_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + arx_args_list(target_date = "2022-01-01") + Condition + Error in `arx_args_list()`: + ! `target_date` must be a date. + +--- + + Code + arx_args_list(n_training_min = "de") + Condition + Error in `arx_args_list()`: + ! `...` must be empty. + x Problematic argument: + * n_training_min = "de" + +--- + + Code + arx_args_list(epi_keys = 1) + Condition + Error in `arx_args_list()`: + ! `...` must be empty. + x Problematic argument: + * epi_keys = 1 + +# arx forecaster disambiguates quantiles + + Code + compare_quantile_args(alist, tlist) + Condition + Error in `compare_quantile_args()`: + ! You have specified different, non-default, quantiles in the trainier and `arx_args` options. + i Please only specify quantiles in one location. + +# arx_lags_validator handles named & unnamed lists as expected + + Code + arx_lags_validator(pred_vec, lags_finit_fn_switch2) + Condition + Error in `arx_lags_validator()`: + ! You have requested 2 predictor(s) but 3 different lags. + i Lags must be a vector or a list with length == number of predictors. + +--- + + Code + arx_lags_validator(pred_vec, lags_init_other_name) + Condition + Error in `arx_lags_validator()`: + ! If lags is a named list, then all predictors must be present. + i The predictors are `death_rate` and `case_rate`. + i So lags is missing `case_rate`'. + diff --git a/tests/testthat/_snaps/arx_cargs_list.md b/tests/testthat/_snaps/arx_cargs_list.md new file mode 100644 index 000000000..30ccb4d36 --- /dev/null +++ b/tests/testthat/_snaps/arx_cargs_list.md @@ -0,0 +1,92 @@ +# arx_class_args checks inputs + + Code + arx_class_args_list(ahead = c(0, 4)) + Condition + Error in `arx_class_args_list()`: + ! `ahead` must be a scalar. + +--- + + Code + arx_class_args_list(n_training = c(28, 65)) + Condition + Error in `arx_class_args_list()`: + ! `n_training` must be a scalar. + +--- + + Code + arx_class_args_list(ahead = -1) + Condition + Error in `arx_class_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_class_args_list(ahead = 1.5) + Condition + Error in `arx_class_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + arx_class_args_list(n_training = -1) + Condition + Error in `arx_class_args_list()`: + ! `n_training` must be a strictly positive number. + +--- + + Code + arx_class_args_list(n_training = 1.5) + Condition + Error in `arx_class_args_list()`: + ! `n_training` must be a positive integer. + +--- + + Code + arx_class_args_list(lags = c(-1, 0)) + Condition + Error in `arx_class_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_class_args_list(lags = list(c(1:5, 6.5), 2:8)) + Condition + Error in `arx_class_args_list()`: + ! `lags` must be non-negative integers. + +--- + + Code + arx_class_args_list(target_date = "2022-01-01") + Condition + Error in `arx_class_args_list()`: + ! `target_date` must be a date. + +--- + + Code + arx_class_args_list(n_training_min = "de") + Condition + Error in `arx_class_args_list()`: + ! `...` must be empty. + x Problematic argument: + * n_training_min = "de" + +--- + + Code + arx_class_args_list(epi_keys = 1) + Condition + Error in `arx_class_args_list()`: + ! `...` must be empty. + x Problematic argument: + * epi_keys = 1 + diff --git a/tests/testthat/_snaps/bake-method.md b/tests/testthat/_snaps/bake-method.md new file mode 100644 index 000000000..eee28cc4b --- /dev/null +++ b/tests/testthat/_snaps/bake-method.md @@ -0,0 +1,9 @@ +# bake method works in all cases + + Code + bake(prep(r, edf), NULL, composition = "matrix") + Condition + Error in `hardhat::recompose()`: + ! `data` must only contain numeric columns. + i These columns aren't numeric: "geo_value" and "time_value". + diff --git a/tests/testthat/_snaps/check-training-set.md b/tests/testthat/_snaps/check-training-set.md new file mode 100644 index 000000000..e5eec7e7c --- /dev/null +++ b/tests/testthat/_snaps/check-training-set.md @@ -0,0 +1,20 @@ +# training set validation works + + Code + validate_meta_match(t1, template, "geo_type", "abort") + Condition + Error in `validate_meta_match()`: + ! The `geo_type` of the training data appears to be different from that + used to construct the recipe. This may result in unexpected consequences. + i Training `geo_type` is 'county'. + i Originally, it was 'state'. + +--- + + Code + epi_check_training_set(t4, rec) + Condition + Error in `epi_check_training_set()`: + ! The recipe specifies keys which are not in the training data. + i The training set is missing columns for missing_col. + diff --git a/tests/testthat/_snaps/check_enough_train_data.md b/tests/testthat/_snaps/check_enough_train_data.md new file mode 100644 index 000000000..8f2389acb --- /dev/null +++ b/tests/testthat/_snaps/check_enough_train_data.md @@ -0,0 +1,46 @@ +# check_enough_train_data works on pooled data + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, + drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +--- + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, + drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +# check_enough_train_data works on unpooled data + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", + drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +--- + + Code + epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, + epi_keys = "geo_value", drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: x and y. + +# check_enough_train_data works with all_predictors() downstream of constructed terms + + Code + epi_recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% + check_enough_train_data(all_predictors(), y, n = 2 * n - 5) %>% prep( + toy_epi_df) %>% bake(new_data = NULL) + Condition + Error in `prep()`: + ! The following columns don't have enough data to predict: lag_1_x, lag_2_x, and y. + diff --git a/tests/testthat/_snaps/dist_quantiles.md b/tests/testthat/_snaps/dist_quantiles.md new file mode 100644 index 000000000..da7e50100 --- /dev/null +++ b/tests/testthat/_snaps/dist_quantiles.md @@ -0,0 +1,56 @@ +# constructor returns reasonable quantiles + + Code + new_quantiles(rnorm(5), rnorm(5)) + Condition + Error in `new_quantiles()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + new_quantiles(sort(rnorm(5)), sort(runif(2))) + Condition + Error in `new_quantiles()`: + ! length(values) == length(quantile_levels) is not TRUE + +--- + + Code + new_quantiles(c(2, 1, 3, 4, 5), c(0.1, 0.1, 0.2, 0.5, 0.8)) + Condition + Error in `new_quantiles()`: + ! !vctrs::vec_duplicate_any(quantile_levels) is not TRUE + +--- + + Code + new_quantiles(c(2, 1, 3, 4, 5), c(0.1, 0.15, 0.2, 0.5, 0.8)) + Condition + Error in `new_quantiles()`: + ! `values[order(quantile_levels)]` produces unsorted quantiles. + +--- + + Code + new_quantiles(c(1, 2, 3), c(0.1, 0.2, 3)) + Condition + Error in `new_quantiles()`: + ! `quantile_levels` must lie in [0, 1]. + +# arithmetic works on quantiles + + Code + sum(dstn) + Condition + Error in `mapply()`: + ! You can't perform arithmetic between two distributions like this. + +--- + + Code + suppressWarnings(dstn + distributional::dist_normal()) + Condition + Error: + ! non-numeric argument to binary operator + diff --git a/tests/testthat/_snaps/enframer.md b/tests/testthat/_snaps/enframer.md new file mode 100644 index 000000000..4b05dbff3 --- /dev/null +++ b/tests/testthat/_snaps/enframer.md @@ -0,0 +1,32 @@ +# enframer errors/works as needed + + Code + enframer(1:5, letters[1]) + Condition + Error in `enframer()`: + ! is.data.frame(df) is not TRUE + +--- + + Code + enframer(data.frame(a = 1:5), 1:3) + Condition + Error in `enframer()`: + ! `x` must be of type . + +--- + + Code + enframer(data.frame(a = 1:5), letters[1:3]) + Condition + Error in `enframer()`: + ! In enframer: some new cols match existing column names + +--- + + Code + enframer(data.frame(aa = 1:5), letters[1:2], fill = 1:4) + Condition + Error in `enframer()`: + ! length(fill) == 1 || length(fill) == nrow(df) is not TRUE + diff --git a/tests/testthat/_snaps/epi_recipe.md b/tests/testthat/_snaps/epi_recipe.md index 3d797461d..24b046678 100644 --- a/tests/testthat/_snaps/epi_recipe.md +++ b/tests/testthat/_snaps/epi_recipe.md @@ -22,3 +22,11 @@ Error in `epi_recipe()`: ! `x` must be an or a , not a . +# add/update/adjust/remove epi_recipe works as intended + + Code + workflows::extract_preprocessor(wf)$steps + Condition + Error in `workflows::extract_preprocessor()`: + ! The workflow does not have a preprocessor. + diff --git a/tests/testthat/_snaps/epi_workflow.md b/tests/testthat/_snaps/epi_workflow.md index d46dad6c1..006333423 100644 --- a/tests/testthat/_snaps/epi_workflow.md +++ b/tests/testthat/_snaps/epi_workflow.md @@ -1,3 +1,20 @@ +# model can be added/updated/removed from epi_workflow + + Code + extract_spec_parsnip(wf) + Condition + Error in `extract_spec_parsnip()`: + ! The workflow does not have a model spec. + +# forecast method errors when workflow not fit + + Code + forecast(wf) + Condition + Error in `forecast()`: + ! You cannot `forecast()` a that has not been trained. + i Please use `fit()` before forecasting. + # fit method does not silently drop the class Code diff --git a/tests/testthat/_snaps/extract_argument.md b/tests/testthat/_snaps/extract_argument.md new file mode 100644 index 000000000..d4ff44c95 --- /dev/null +++ b/tests/testthat/_snaps/extract_argument.md @@ -0,0 +1,72 @@ +# layer argument extractor works + + Code + extract_argument(f$layers[[1]], "uhoh", "bubble") + Condition + Error in `extract_argument()`: + ! Requested "uhoh" not found. This is a(n) . + +--- + + Code + extract_argument(f$layers[[1]], "layer_predict", "bubble") + Condition + Error in `extract_argument()`: + ! Requested argument "bubble" not found in "layer_predict". + +--- + + Code + extract_argument(f, "layer_thresh", "quantile_levels") + Condition + Error in `extract_argument()`: + ! frosting object does not contain a "layer_thresh". + +--- + + Code + extract_argument(epi_workflow(), "layer_residual_quantiles", "quantile_levels") + Condition + Error in `extract_frosting()`: + ! The epi_workflow does not have a postprocessor. + +--- + + Code + extract_argument(wf, "layer_predict", c("type", "opts")) + Condition + Error in `FUN()`: + ! `arg` must be a scalar of type . + +# recipe argument extractor works + + Code + extract_argument(r$steps[[1]], "uhoh", "bubble") + Condition + Error in `extract_argument()`: + ! Requested "uhoh" not found. This is a . + +--- + + Code + extract_argument(r$steps[[1]], "step_epi_lag", "bubble") + Condition + Error in `extract_argument()`: + ! Requested argument "bubble" not found in "step_epi_lag". + +--- + + Code + extract_argument(r, "step_lightly", "quantile_levels") + Condition + Error in `extract_argument()`: + ! recipe object does not contain a "step_lightly". + +--- + + Code + extract_argument(epi_workflow(), "step_epi_lag", "lag") + Condition + Error in `extract_argument()`: + ! The workflow must have a recipe preprocessor. + diff --git a/tests/testthat/_snaps/flatline_args_list.md b/tests/testthat/_snaps/flatline_args_list.md new file mode 100644 index 000000000..02053f95b --- /dev/null +++ b/tests/testthat/_snaps/flatline_args_list.md @@ -0,0 +1,128 @@ +# flatline_args_list checks inputs + + Code + flatline_args_list(ahead = c(0, 4)) + Condition + Error in `flatline_args_list()`: + ! `ahead` must be a scalar. + +--- + + Code + flatline_args_list(n_training = c(28, 65)) + Condition + Error in `flatline_args_list()`: + ! `n_training` must be a scalar. + +--- + + Code + flatline_args_list(ahead = -1) + Condition + Error in `flatline_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + flatline_args_list(ahead = 1.5) + Condition + Error in `flatline_args_list()`: + ! `ahead` must be a non-negative integer. + +--- + + Code + flatline_args_list(n_training = -1) + Condition + Error in `flatline_args_list()`: + ! `n_training` must be a strictly positive number. + +--- + + Code + flatline_args_list(n_training = 1.5) + Condition + Error in `flatline_args_list()`: + ! `n_training` must be a positive integer. + +--- + + Code + flatline_args_list(lags = c(-1, 0)) + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * lags = c(-1, 0) + +--- + + Code + flatline_args_list(lags = list(c(1:5, 6.5), 2:8)) + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * lags = list(c(1:5, 6.5), 2:8) + +--- + + Code + flatline_args_list(symmetrize = 4) + Condition + Error in `flatline_args_list()`: + ! `symmetrize` must be of type . + +--- + + Code + flatline_args_list(nonneg = 4) + Condition + Error in `flatline_args_list()`: + ! `nonneg` must be of type . + +--- + + Code + flatline_args_list(quantile_levels = -0.1) + Condition + Error in `flatline_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + flatline_args_list(quantile_levels = 1.1) + Condition + Error in `flatline_args_list()`: + ! `quantile_levels` must lie in [0, 1]. + +--- + + Code + flatline_args_list(target_date = "2022-01-01") + Condition + Error in `flatline_args_list()`: + ! `target_date` must be a date. + +--- + + Code + flatline_args_list(n_training_min = "de") + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * n_training_min = "de" + +--- + + Code + flatline_args_list(epi_keys = 1) + Condition + Error in `flatline_args_list()`: + ! `...` must be empty. + x Problematic argument: + * epi_keys = 1 + diff --git a/tests/testthat/_snaps/frosting.md b/tests/testthat/_snaps/frosting.md new file mode 100644 index 000000000..daf7f1ed7 --- /dev/null +++ b/tests/testthat/_snaps/frosting.md @@ -0,0 +1,16 @@ +# frosting validators / constructors work + + Code + wf %>% add_postprocessor(list()) + Condition + Error: + ! `postprocessor` must be a frosting object. + +# frosting can be created/added/updated/adjusted/removed + + Code + frosting(layers = 1:5) + Condition + Error in `frosting()`: + ! Currently, no arguments to `frosting()` are allowed to be non-null. + diff --git a/tests/testthat/_snaps/get_test_data.md b/tests/testthat/_snaps/get_test_data.md new file mode 100644 index 000000000..e65b0715c --- /dev/null +++ b/tests/testthat/_snaps/get_test_data.md @@ -0,0 +1,66 @@ +# expect insufficient training data error + + Code + get_test_data(recipe = r, x = case_death_rate_subset) + Condition + Error in `get_test_data()`: + ! You supplied insufficient recent data for this recipe. + ! You need at least 367 days of data, + ! but `x` contains only 365. + +# expect error that geo_value or time_value does not exist + + Code + get_test_data(recipe = r, x = wrong_epi_df) + Condition + Error in `get_test_data()`: + ! `x` must be an `epi_df`. + +# NA fill behaves as desired + + Code + get_test_data(r, df, "A") + Condition + Error in `get_test_data()`: + ! `fill_locf` must be of type . + +--- + + Code + get_test_data(r, df, TRUE, -3) + Condition + Error in `get_test_data()`: + ! `n_recent` must be a positive integer. + +--- + + Code + get_test_data(r, df2, TRUE) + Condition + Error in `if (recipes::is_trained(recipe)) ...`: + ! argument is of length zero + +# forecast date behaves + + Code + get_test_data(r, df, TRUE, forecast_date = 9) + Condition + Error in `get_test_data()`: + ! `forecast_date` must be the same class as `x$time_value`. + +--- + + Code + get_test_data(r, df, TRUE, forecast_date = 9L) + Condition + Error in `get_test_data()`: + ! `forecast_date` must be no earlier than `max(x$time_value)` + +--- + + Code + get_test_data(r, df, forecast_date = 9L) + Condition + Error in `get_test_data()`: + ! `forecast_date` must be no earlier than `max(x$time_value)` + diff --git a/tests/testthat/_snaps/layer_add_forecast_date.md b/tests/testthat/_snaps/layer_add_forecast_date.md new file mode 100644 index 000000000..9e829be91 --- /dev/null +++ b/tests/testthat/_snaps/layer_add_forecast_date.md @@ -0,0 +1,42 @@ +# layer validation works + + Code + layer_add_forecast_date(f, c("2022-05-31", "2022-05-31")) + Condition + Error in `layer_add_forecast_date()`: + ! `forecast_date` must be a scalar. + +--- + + Code + layer_add_forecast_date(f, "2022-05-31", id = 2) + Condition + Error in `layer_add_forecast_date()`: + ! `id` must be a scalar of type . + +--- + + Code + layer_add_forecast_date(f, "2022-05-31", id = c("a", "b")) + Condition + Error in `layer_add_forecast_date()`: + ! `id` must be a scalar of type . + +# forecast date works for daily + + Code + predict(wf1, latest_yearly) + Condition + Error: + ! Can't convert `data$time_value` to match type of `time_value` . + +--- + + Code + predict(wf3, latest) + Condition + Error in `layer_add_forecast_date()`: + ! The `forecast_date` was given as a "year" while the + ! `time_type` of the training data was "day". + i See `?epiprocess::epi_df` for descriptions of these are determined. + diff --git a/tests/testthat/_snaps/layer_add_target_date.md b/tests/testthat/_snaps/layer_add_target_date.md new file mode 100644 index 000000000..805a4205d --- /dev/null +++ b/tests/testthat/_snaps/layer_add_target_date.md @@ -0,0 +1,8 @@ +# target date works for daily and yearly + + Code + predict(wf1, latest_bad) + Condition + Error: + ! Can't convert `data$time_value` to match type of `time_value` . + diff --git a/tests/testthat/_snaps/layer_predict.md b/tests/testthat/_snaps/layer_predict.md new file mode 100644 index 000000000..5c353eb4c --- /dev/null +++ b/tests/testthat/_snaps/layer_predict.md @@ -0,0 +1,8 @@ +# layer_predict dots validation + + Code + predict(wf_bad_arg, latest) + Condition + Error: + ! argument "..3" is missing, with no default + diff --git a/tests/testthat/_snaps/layer_residual_quantiles.md b/tests/testthat/_snaps/layer_residual_quantiles.md new file mode 100644 index 000000000..41aa0448d --- /dev/null +++ b/tests/testthat/_snaps/layer_residual_quantiles.md @@ -0,0 +1,18 @@ +# Errors when used with a classifier + + Code + forecast(wf) + Condition + Error in `grab_residuals()`: + ! For meaningful residuals, the predictor should be a regression model. + +# flatline_forecaster correctly errors when n_training < ahead + + Code + flatline_forecaster(jhu, "death_rate", args_list = flatline_args_list(ahead = 10, + n_training = 9)) + Condition + Error in `slather()`: + ! Residual quantiles could not be calculated due to missing residuals. + i This may be due to `n_train` < `ahead` in your . + diff --git a/tests/testthat/_snaps/layers.md b/tests/testthat/_snaps/layers.md new file mode 100644 index 000000000..a0474eab6 --- /dev/null +++ b/tests/testthat/_snaps/layers.md @@ -0,0 +1,24 @@ +# A layer can be updated in frosting + + Code + update(f$layers[[1]], lower = 100) + Condition + Error in `recipes:::update_fields()`: + ! The step you are trying to update, `layer_predict()`, does not have the lower field. + +--- + + Code + update(f$layers[[3]], lower = 100) + Condition + Error in `f$layers[[3]]`: + ! subscript out of bounds + +--- + + Code + update(f$layers[[2]], bad_param = 100) + Condition + Error in `recipes:::update_fields()`: + ! The step you are trying to update, `layer_threshold()`, does not have the bad_param field. + diff --git a/tests/testthat/_snaps/parse_period.md b/tests/testthat/_snaps/parse_period.md new file mode 100644 index 000000000..bc782dea7 --- /dev/null +++ b/tests/testthat/_snaps/parse_period.md @@ -0,0 +1,32 @@ +# parse_period works + + Code + parse_period(c(1, 2)) + Condition + Error in `parse_period()`: + ! `x` must be a scalar. + +--- + + Code + parse_period(c(1.3)) + Condition + Error in `parse_period()`: + ! rlang::is_integerish(x) is not TRUE + +--- + + Code + parse_period("1 year") + Condition + Error in `parse_period()`: + ! incompatible timespan in `aheads`. + +--- + + Code + parse_period("2 weeks later") + Condition + Error in `parse_period()`: + ! incompatible timespan in `aheads`. + diff --git a/tests/testthat/_snaps/parsnip_model_validation.md b/tests/testthat/_snaps/parsnip_model_validation.md new file mode 100644 index 000000000..365e6b2b8 --- /dev/null +++ b/tests/testthat/_snaps/parsnip_model_validation.md @@ -0,0 +1,18 @@ +# forecaster can validate parsnip model + + Code + get_parsnip_mode(l) + Condition + Error in `get_parsnip_mode()`: + ! `trainer` must be a `parsnip` model. + i This trainer has class: . + +--- + + Code + is_classification(l) + Condition + Error in `get_parsnip_mode()`: + ! `trainer` must be a `parsnip` model. + i This trainer has class: . + diff --git a/tests/testthat/_snaps/pivot_quantiles.md b/tests/testthat/_snaps/pivot_quantiles.md new file mode 100644 index 000000000..184eb62a6 --- /dev/null +++ b/tests/testthat/_snaps/pivot_quantiles.md @@ -0,0 +1,51 @@ +# quantile pivotting wider behaves + + Code + pivot_quantiles_wider(tib, a) + Condition + Error in `UseMethod()`: + ! no applicable method for 'family' applied to an object of class "c('integer', 'numeric')" + +--- + + Code + pivot_quantiles_wider(tib, c) + Condition + Error in `validate_pivot_quantiles()`: + ! Variables(s) `c` are not `dist_quantiles`. Cannot pivot them. + +--- + + Code + pivot_quantiles_wider(tib, d1) + Condition + Error in `pivot_quantiles_wider()`: + ! Quantiles must be the same length and have the same set of taus. + i Check failed for variables(s) `d1`. + +# quantile pivotting longer behaves + + Code + pivot_quantiles_longer(tib, a) + Condition + Error in `UseMethod()`: + ! no applicable method for 'family' applied to an object of class "c('integer', 'numeric')" + +--- + + Code + pivot_quantiles_longer(tib, c) + Condition + Error in `validate_pivot_quantiles()`: + ! Variables(s) `c` are not `dist_quantiles`. Cannot pivot them. + +--- + + Code + pivot_quantiles_longer(tib, d1, d3) + Condition + Error in `pivot_quantiles_longer()`: + ! Some selected columns contain different numbers of quantiles. + The result would be a very long . + To do this anyway, rerun with `.ignore_length_check = TRUE`. + diff --git a/tests/testthat/_snaps/population_scaling.md b/tests/testthat/_snaps/population_scaling.md new file mode 100644 index 000000000..9263e8e1e --- /dev/null +++ b/tests/testthat/_snaps/population_scaling.md @@ -0,0 +1,16 @@ +# expect error if `by` selector does not match + + Code + wf <- epi_workflow(r, parsnip::linear_reg()) %>% fit(jhu) %>% add_frosting(f) + Condition + Error in `hardhat::validate_column_names()`: + ! The following required columns are missing: 'a'. + +--- + + Code + forecast(wf) + Condition + Error in `hardhat::validate_column_names()`: + ! The following required columns are missing: 'nothere'. + diff --git a/tests/testthat/_snaps/shuffle.md b/tests/testthat/_snaps/shuffle.md new file mode 100644 index 000000000..53eea9b92 --- /dev/null +++ b/tests/testthat/_snaps/shuffle.md @@ -0,0 +1,8 @@ +# shuffle works + + Code + shuffle(matrix(NA, 2, 2)) + Condition + Error in `shuffle()`: + ! is.vector(x) is not TRUE + diff --git a/tests/testthat/_snaps/step_epi_slide.md b/tests/testthat/_snaps/step_epi_slide.md index 27ca908b7..a4b9d64c8 100644 --- a/tests/testthat/_snaps/step_epi_slide.md +++ b/tests/testthat/_snaps/step_epi_slide.md @@ -118,6 +118,22 @@ Error in `validate_slide_fun()`: ! In, `step_epi_slide()`, `.f` must be a function. +--- + + Code + r %>% step_epi_slide(value) + Condition + Error in `step_epi_slide()`: + ! argument ".f" is missing, with no default + +--- + + Code + r %>% step_epi_slide(value, .f = 1) + Condition + Error in `validate_slide_fun()`: + ! In, `step_epi_slide()`, `.f` must be a function. + # epi_slide handles different function specs Code diff --git a/tests/testthat/_snaps/wis-dist-quantiles.md b/tests/testthat/_snaps/wis-dist-quantiles.md new file mode 100644 index 000000000..fb9cfbdf6 --- /dev/null +++ b/tests/testthat/_snaps/wis-dist-quantiles.md @@ -0,0 +1,17 @@ +# wis dispatches and produces the correct values + + Code + weighted_interval_score(1:10, 10) + Condition + Error in `weighted_interval_score()`: + ! Weighted interval score can only be calculated if `x` + has class . + +--- + + Code + weighted_interval_score(dist_quantiles(list(1:4, 8:11), 1:4 / 5), 1:3) + Condition + Error in `weighted_interval_score()`: + ! Can't recycle `x` (size 2) to match `actual` (size 3). + diff --git a/tests/testthat/test-arx_args_list.R b/tests/testthat/test-arx_args_list.R index 9d81be024..03cbc0025 100644 --- a/tests/testthat/test-arx_args_list.R +++ b/tests/testthat/test-arx_args_list.R @@ -1,30 +1,30 @@ test_that("arx_args checks inputs", { expect_s3_class(arx_args_list(), c("arx_fcast", "alist")) - expect_error(arx_args_list(ahead = c(0, 4))) - expect_error(arx_args_list(n_training = c(28, 65))) + expect_snapshot(error = TRUE, arx_args_list(ahead = c(0, 4))) + expect_snapshot(error = TRUE, arx_args_list(n_training = c(28, 65))) - expect_error(arx_args_list(ahead = -1)) - expect_error(arx_args_list(ahead = 1.5)) - expect_error(arx_args_list(n_training = -1)) - expect_error(arx_args_list(n_training = 1.5)) - expect_error(arx_args_list(lags = c(-1, 0))) - expect_error(arx_args_list(lags = list(c(1:5, 6.5), 2:8))) + expect_snapshot(error = TRUE, arx_args_list(ahead = -1)) + expect_snapshot(error = TRUE, arx_args_list(ahead = 1.5)) + expect_snapshot(error = TRUE, arx_args_list(n_training = -1)) + expect_snapshot(error = TRUE, arx_args_list(n_training = 1.5)) + expect_snapshot(error = TRUE, arx_args_list(lags = c(-1, 0))) + expect_snapshot(error = TRUE, arx_args_list(lags = list(c(1:5, 6.5), 2:8))) - expect_error(arx_args_list(symmetrize = 4)) - expect_error(arx_args_list(nonneg = 4)) + expect_snapshot(error = TRUE, arx_args_list(symmetrize = 4)) + expect_snapshot(error = TRUE, arx_args_list(nonneg = 4)) - expect_error(arx_args_list(quantile_levels = -.1)) - expect_error(arx_args_list(quantile_levels = 1.1)) + expect_snapshot(error = TRUE, arx_args_list(quantile_levels = -.1)) + expect_snapshot(error = TRUE, arx_args_list(quantile_levels = 1.1)) expect_type(arx_args_list(quantile_levels = NULL), "list") - expect_error(arx_args_list(target_date = "2022-01-01")) + expect_snapshot(error = TRUE, arx_args_list(target_date = "2022-01-01")) expect_identical( arx_args_list(target_date = as.Date("2022-01-01"))$target_date, as.Date("2022-01-01") ) - expect_error(arx_args_list(n_training_min = "de")) - expect_error(arx_args_list(epi_keys = 1)) + expect_snapshot(error = TRUE, arx_args_list(n_training_min = "de")) + expect_snapshot(error = TRUE, arx_args_list(epi_keys = 1)) expect_warning(arx_args_list( forecast_date = as.Date("2022-01-01"), @@ -58,7 +58,7 @@ test_that("arx forecaster disambiguates quantiles", { sort(unique(tlist)) ) alist <- c(.1, .3, .5, .7, .9) # neither default, and different, - expect_error(compare_quantile_args(alist, tlist)) + expect_snapshot(error = TRUE, compare_quantile_args(alist, tlist)) }) test_that("arx_lags_validator handles named & unnamed lists as expected", { @@ -94,7 +94,7 @@ test_that("arx_lags_validator handles named & unnamed lists as expected", { ) # More lags than predictors - Error - expect_error(arx_lags_validator(pred_vec, lags_finit_fn_switch2)) + expect_snapshot(error = TRUE, arx_lags_validator(pred_vec, lags_finit_fn_switch2)) # Unnamed list of lags lags_init_un <- list(c(0, 7, 14), c(0, 1, 2, 3, 7, 14)) @@ -115,5 +115,5 @@ test_that("arx_lags_validator handles named & unnamed lists as expected", { # Try use a name not in predictors - Error lags_init_other_name <- list(death_rate = c(0, 7, 14), test_var = c(0, 1, 2, 3, 7, 14)) - expect_error(arx_lags_validator(pred_vec, lags_init_other_name)) + expect_snapshot(error = TRUE, arx_lags_validator(pred_vec, lags_init_other_name)) }) diff --git a/tests/testthat/test-arx_cargs_list.R b/tests/testthat/test-arx_cargs_list.R index d225cf62a..12087e45f 100644 --- a/tests/testthat/test-arx_cargs_list.R +++ b/tests/testthat/test-arx_cargs_list.R @@ -1,24 +1,24 @@ test_that("arx_class_args checks inputs", { expect_s3_class(arx_class_args_list(), c("arx_class", "alist")) - expect_error(arx_class_args_list(ahead = c(0, 4))) - expect_error(arx_class_args_list(n_training = c(28, 65))) + expect_snapshot(error = TRUE, arx_class_args_list(ahead = c(0, 4))) + expect_snapshot(error = TRUE, arx_class_args_list(n_training = c(28, 65))) - expect_error(arx_class_args_list(ahead = -1)) - expect_error(arx_class_args_list(ahead = 1.5)) - expect_error(arx_class_args_list(n_training = -1)) - expect_error(arx_class_args_list(n_training = 1.5)) - expect_error(arx_class_args_list(lags = c(-1, 0))) - expect_error(arx_class_args_list(lags = list(c(1:5, 6.5), 2:8))) + expect_snapshot(error = TRUE, arx_class_args_list(ahead = -1)) + expect_snapshot(error = TRUE, arx_class_args_list(ahead = 1.5)) + expect_snapshot(error = TRUE, arx_class_args_list(n_training = -1)) + expect_snapshot(error = TRUE, arx_class_args_list(n_training = 1.5)) + expect_snapshot(error = TRUE, arx_class_args_list(lags = c(-1, 0))) + expect_snapshot(error = TRUE, arx_class_args_list(lags = list(c(1:5, 6.5), 2:8))) - expect_error(arx_class_args_list(target_date = "2022-01-01")) + expect_snapshot(error = TRUE, arx_class_args_list(target_date = "2022-01-01")) expect_identical( arx_class_args_list(target_date = as.Date("2022-01-01"))$target_date, as.Date("2022-01-01") ) - expect_error(arx_class_args_list(n_training_min = "de")) - expect_error(arx_class_args_list(epi_keys = 1)) + expect_snapshot(error = TRUE, arx_class_args_list(n_training_min = "de")) + expect_snapshot(error = TRUE, arx_class_args_list(epi_keys = 1)) expect_warning(arx_class_args_list( forecast_date = as.Date("2022-01-01"), diff --git a/tests/testthat/test-bake-method.R b/tests/testthat/test-bake-method.R index 0e2746cf2..06f861012 100644 --- a/tests/testthat/test-bake-method.R +++ b/tests/testthat/test-bake-method.R @@ -25,5 +25,5 @@ test_that("bake method works in all cases", { expect_s3_class(bake(prep(r, edf), NULL, composition = "tibble"), "tbl_df") expect_s3_class(bake(prep(r, edf), NULL, composition = "data.frame"), "data.frame") # can't be a matrix because time_value/geo_value aren't numeric - expect_error(bake(prep(r, edf), NULL, composition = "matrix")) + expect_snapshot(error = TRUE, bake(prep(r, edf), NULL, composition = "matrix")) }) diff --git a/tests/testthat/test-check-training-set.R b/tests/testthat/test-check-training-set.R index 0f9246282..64d4d6945 100644 --- a/tests/testthat/test-check-training-set.R +++ b/tests/testthat/test-check-training-set.R @@ -7,7 +7,7 @@ test_that("training set validation works", { expect_silent(validate_meta_match(template, template, "time_type", "blah")) attr(t1, "metadata")$geo_type <- "county" expect_warning(validate_meta_match(t1, template, "geo_type"), "county") - expect_error(validate_meta_match(t1, template, "geo_type", "abort"), "county") + expect_snapshot(error = TRUE, validate_meta_match(t1, template, "geo_type", "abort")) expect_identical(template, epi_check_training_set(template, rec)) @@ -25,5 +25,5 @@ test_that("training set validation works", { expect_warning(t4 <- epi_check_training_set(t3, rec)) expect_identical(rec$template, t4) attr(rec$template, "metadata")$other_keys <- "missing_col" - expect_error(epi_check_training_set(t4, rec), "missing_col") + expect_snapshot(error = TRUE, epi_check_training_set(t4, rec)) }) diff --git a/tests/testthat/test-check_enough_train_data.R b/tests/testthat/test-check_enough_train_data.R index 502ea06f1..9b2ef5f34 100644 --- a/tests/testthat/test-check_enough_train_data.R +++ b/tests/testthat/test-check_enough_train_data.R @@ -23,15 +23,16 @@ test_that("check_enough_train_data works on pooled data", { bake(new_data = NULL) ) # Check both column don't have enough data - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, drop_na = FALSE) %>% prep(toy_epi_df) %>% - bake(new_data = NULL), - regexp = "The following columns don't have enough data" + bake(new_data = NULL) ) # Check drop_na works - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, drop_na = TRUE) %>% prep(toy_epi_df) %>% @@ -48,15 +49,16 @@ test_that("check_enough_train_data works on unpooled data", { bake(new_data = NULL) ) # Check one column don't have enough data - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", drop_na = FALSE) %>% prep(toy_epi_df) %>% - bake(new_data = NULL), - regexp = "The following columns don't have enough data" + bake(new_data = NULL) ) # Check drop_na works - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, epi_keys = "geo_value", drop_na = TRUE) %>% prep(toy_epi_df) %>% @@ -114,7 +116,8 @@ test_that("check_enough_train_data works with all_predictors() downstream of con prep(toy_epi_df) %>% bake(new_data = NULL) ) - expect_error( + expect_snapshot( + error = TRUE, epi_recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% check_enough_train_data(all_predictors(), y, n = 2 * n - 5) %>% diff --git a/tests/testthat/test-dist_quantiles.R b/tests/testthat/test-dist_quantiles.R index 66456ef80..8112326dc 100644 --- a/tests/testthat/test-dist_quantiles.R +++ b/tests/testthat/test-dist_quantiles.R @@ -1,13 +1,13 @@ library(distributional) test_that("constructor returns reasonable quantiles", { - expect_error(new_quantiles(rnorm(5), rnorm(5))) + expect_snapshot(error = TRUE, new_quantiles(rnorm(5), rnorm(5))) expect_silent(new_quantiles(sort(rnorm(5)), sort(runif(5)))) - expect_error(new_quantiles(sort(rnorm(5)), sort(runif(2)))) + expect_snapshot(error = TRUE, new_quantiles(sort(rnorm(5)), sort(runif(2)))) expect_silent(new_quantiles(1:5, 1:5 / 10)) - expect_error(new_quantiles(c(2, 1, 3, 4, 5), c(.1, .1, .2, .5, .8))) - expect_error(new_quantiles(c(2, 1, 3, 4, 5), c(.1, .15, .2, .5, .8))) - expect_error(new_quantiles(c(1, 2, 3), c(.1, .2, 3))) + expect_snapshot(error = TRUE, new_quantiles(c(2, 1, 3, 4, 5), c(.1, .1, .2, .5, .8))) + expect_snapshot(error = TRUE, new_quantiles(c(2, 1, 3, 4, 5), c(.1, .15, .2, .5, .8))) + expect_snapshot(error = TRUE, new_quantiles(c(1, 2, 3), c(.1, .2, 3))) }) @@ -106,6 +106,6 @@ test_that("arithmetic works on quantiles", { expect_identical(dstn / 4, dstn2) expect_identical((1 / 4) * dstn, dstn2) - expect_error(sum(dstn)) - expect_error(suppressWarnings(dstn + distributional::dist_normal())) + expect_snapshot(error = TRUE, sum(dstn)) + expect_snapshot(error = TRUE, suppressWarnings(dstn + distributional::dist_normal())) }) diff --git a/tests/testthat/test-enframer.R b/tests/testthat/test-enframer.R index c555ea9b2..0926c587b 100644 --- a/tests/testthat/test-enframer.R +++ b/tests/testthat/test-enframer.R @@ -1,11 +1,11 @@ test_that("enframer errors/works as needed", { template1 <- data.frame(aa = 1:5, a = NA, b = NA, c = NA) template2 <- data.frame(aa = 1:5, a = 2:6, b = 2:6, c = 2:6) - expect_error(enframer(1:5, letters[1])) - expect_error(enframer(data.frame(a = 1:5), 1:3)) - expect_error(enframer(data.frame(a = 1:5), letters[1:3])) + expect_snapshot(error = TRUE, enframer(1:5, letters[1])) + expect_snapshot(error = TRUE, enframer(data.frame(a = 1:5), 1:3)) + expect_snapshot(error = TRUE, enframer(data.frame(a = 1:5), letters[1:3])) expect_identical(enframer(data.frame(aa = 1:5), letters[1:3]), template1) - expect_error(enframer(data.frame(aa = 1:5), letters[1:2], fill = 1:4)) + expect_snapshot(error = TRUE, enframer(data.frame(aa = 1:5), letters[1:2], fill = 1:4)) expect_identical( enframer(data.frame(aa = 1:5), letters[1:3], fill = 2:6), template2 diff --git a/tests/testthat/test-epi_recipe.R b/tests/testthat/test-epi_recipe.R index f8933b018..1b06cf24c 100644 --- a/tests/testthat/test-epi_recipe.R +++ b/tests/testthat/test-epi_recipe.R @@ -155,6 +155,6 @@ test_that("add/update/adjust/remove epi_recipe works as intended", { wf <- remove_epi_recipe(wf) - expect_error(workflows::extract_preprocessor(wf)$steps) + expect_snapshot(error = TRUE, workflows::extract_preprocessor(wf)$steps) expect_equal(wf$pre$actions$recipe$recipe, NULL) }) diff --git a/tests/testthat/test-epi_workflow.R b/tests/testthat/test-epi_workflow.R index 01eff4209..8bb58b0bc 100644 --- a/tests/testthat/test-epi_workflow.R +++ b/tests/testthat/test-epi_workflow.R @@ -59,7 +59,7 @@ test_that("model can be added/updated/removed from epi_workflow", { expect_equal(class(model_spec2), c("linear_reg", "model_spec")) wf <- remove_model(wf) - expect_error(extract_spec_parsnip(wf)) + expect_snapshot(error = TRUE, extract_spec_parsnip(wf)) expect_equal(wf$fit$actions$model$spec, NULL) }) @@ -103,7 +103,7 @@ test_that("forecast method errors when workflow not fit", { step_epi_naomit() wf <- epi_workflow(r, parsnip::linear_reg()) - expect_error(forecast(wf)) + expect_snapshot(error = TRUE, forecast(wf)) }) test_that("fit method does not silently drop the class", { diff --git a/tests/testthat/test-extract_argument.R b/tests/testthat/test-extract_argument.R index 3250b2991..7434763e7 100644 --- a/tests/testthat/test-extract_argument.R +++ b/tests/testthat/test-extract_argument.R @@ -4,27 +4,27 @@ test_that("layer argument extractor works", { layer_residual_quantiles(quantile_levels = c(0.0275, 0.975), symmetrize = FALSE) %>% layer_naomit(.pred) - expect_error(extract_argument(f$layers[[1]], "uhoh", "bubble")) - expect_error(extract_argument(f$layers[[1]], "layer_predict", "bubble")) + expect_snapshot(error = TRUE, extract_argument(f$layers[[1]], "uhoh", "bubble")) + expect_snapshot(error = TRUE, extract_argument(f$layers[[1]], "layer_predict", "bubble")) expect_identical( extract_argument(f$layers[[2]], "layer_residual_quantiles", "quantile_levels"), c(0.0275, 0.9750) ) - expect_error(extract_argument(f, "layer_thresh", "quantile_levels")) + expect_snapshot(error = TRUE, extract_argument(f, "layer_thresh", "quantile_levels")) expect_identical( extract_argument(f, "layer_residual_quantiles", "quantile_levels"), c(0.0275, 0.9750) ) wf <- epi_workflow(postprocessor = f) - expect_error(extract_argument(epi_workflow(), "layer_residual_quantiles", "quantile_levels")) + expect_snapshot(error = TRUE, extract_argument(epi_workflow(), "layer_residual_quantiles", "quantile_levels")) expect_identical( extract_argument(wf, "layer_residual_quantiles", "quantile_levels"), c(0.0275, 0.9750) ) - expect_error(extract_argument(wf, "layer_predict", c("type", "opts"))) + expect_snapshot(error = TRUE, extract_argument(wf, "layer_predict", c("type", "opts"))) }) test_that("recipe argument extractor works", { @@ -41,19 +41,19 @@ test_that("recipe argument extractor works", { step_naomit(all_outcomes(), skip = TRUE) - expect_error(extract_argument(r$steps[[1]], "uhoh", "bubble")) - expect_error(extract_argument(r$steps[[1]], "step_epi_lag", "bubble")) + expect_snapshot(error = TRUE, extract_argument(r$steps[[1]], "uhoh", "bubble")) + expect_snapshot(error = TRUE, extract_argument(r$steps[[1]], "step_epi_lag", "bubble")) expect_identical(extract_argument(r$steps[[2]], "step_epi_ahead", "ahead"), 7L) - expect_error(extract_argument(r, "step_lightly", "quantile_levels")) + expect_snapshot(error = TRUE, extract_argument(r, "step_lightly", "quantile_levels")) expect_identical( extract_argument(r, "step_epi_lag", "lag"), list(c(0L, 7L, 14L), c(0L, 7L, 14L)) ) wf <- epi_workflow(preprocessor = r) - expect_error(extract_argument(epi_workflow(), "step_epi_lag", "lag")) + expect_snapshot(error = TRUE, extract_argument(epi_workflow(), "step_epi_lag", "lag")) expect_identical( extract_argument(wf, "step_epi_lag", "lag"), list(c(0L, 7L, 14L), c(0L, 7L, 14L)) diff --git a/tests/testthat/test-flatline_args_list.R b/tests/testthat/test-flatline_args_list.R index 86f42a208..6359afc27 100644 --- a/tests/testthat/test-flatline_args_list.R +++ b/tests/testthat/test-flatline_args_list.R @@ -1,30 +1,30 @@ test_that("flatline_args_list checks inputs", { expect_s3_class(flatline_args_list(), c("flat_fcast", "alist")) - expect_error(flatline_args_list(ahead = c(0, 4))) - expect_error(flatline_args_list(n_training = c(28, 65))) + expect_snapshot(error = TRUE, flatline_args_list(ahead = c(0, 4))) + expect_snapshot(error = TRUE, flatline_args_list(n_training = c(28, 65))) - expect_error(flatline_args_list(ahead = -1)) - expect_error(flatline_args_list(ahead = 1.5)) - expect_error(flatline_args_list(n_training = -1)) - expect_error(flatline_args_list(n_training = 1.5)) - expect_error(flatline_args_list(lags = c(-1, 0))) - expect_error(flatline_args_list(lags = list(c(1:5, 6.5), 2:8))) + expect_snapshot(error = TRUE, flatline_args_list(ahead = -1)) + expect_snapshot(error = TRUE, flatline_args_list(ahead = 1.5)) + expect_snapshot(error = TRUE, flatline_args_list(n_training = -1)) + expect_snapshot(error = TRUE, flatline_args_list(n_training = 1.5)) + expect_snapshot(error = TRUE, flatline_args_list(lags = c(-1, 0))) + expect_snapshot(error = TRUE, flatline_args_list(lags = list(c(1:5, 6.5), 2:8))) - expect_error(flatline_args_list(symmetrize = 4)) - expect_error(flatline_args_list(nonneg = 4)) + expect_snapshot(error = TRUE, flatline_args_list(symmetrize = 4)) + expect_snapshot(error = TRUE, flatline_args_list(nonneg = 4)) - expect_error(flatline_args_list(quantile_levels = -.1)) - expect_error(flatline_args_list(quantile_levels = 1.1)) + expect_snapshot(error = TRUE, flatline_args_list(quantile_levels = -.1)) + expect_snapshot(error = TRUE, flatline_args_list(quantile_levels = 1.1)) expect_type(flatline_args_list(quantile_levels = NULL), "list") - expect_error(flatline_args_list(target_date = "2022-01-01")) + expect_snapshot(error = TRUE, flatline_args_list(target_date = "2022-01-01")) expect_identical( flatline_args_list(target_date = as.Date("2022-01-01"))$target_date, as.Date("2022-01-01") ) - expect_error(flatline_args_list(n_training_min = "de")) - expect_error(flatline_args_list(epi_keys = 1)) + expect_snapshot(error = TRUE, flatline_args_list(n_training_min = "de")) + expect_snapshot(error = TRUE, flatline_args_list(epi_keys = 1)) # Detect mismatched ahead and target_date - forecast_date difference expect_warning(flatline_args_list( diff --git a/tests/testthat/test-frosting.R b/tests/testthat/test-frosting.R index 5cab9c494..1bdce3b5a 100644 --- a/tests/testthat/test-frosting.R +++ b/tests/testthat/test-frosting.R @@ -7,7 +7,7 @@ test_that("frosting validators / constructors work", { expect_false(has_postprocessor_frosting(wf)) expect_silent(wf %>% add_frosting(new_frosting())) expect_silent(wf %>% add_postprocessor(new_frosting())) - expect_error(wf %>% add_postprocessor(list())) + expect_snapshot(error = TRUE, wf %>% add_postprocessor(list())) wf <- wf %>% add_frosting(new_frosting()) expect_true(has_postprocessor(wf)) @@ -16,7 +16,7 @@ test_that("frosting validators / constructors work", { test_that("frosting can be created/added/updated/adjusted/removed", { f <- frosting() - expect_error(frosting(layers = 1:5)) + expect_snapshot(error = TRUE, frosting(layers = 1:5)) wf <- epi_workflow() %>% add_frosting(f) expect_true(has_postprocessor_frosting(wf)) wf1 <- update_frosting(wf, frosting() %>% layer_predict() %>% layer_threshold(.pred)) diff --git a/tests/testthat/test-get_test_data.R b/tests/testthat/test-get_test_data.R index 035fc6463..aa799150b 100644 --- a/tests/testthat/test-get_test_data.R +++ b/tests/testthat/test-get_test_data.R @@ -25,7 +25,7 @@ test_that("expect insufficient training data error", { step_naomit(all_predictors()) %>% step_naomit(all_outcomes(), skip = TRUE) - expect_error(get_test_data(recipe = r, x = case_death_rate_subset)) + expect_snapshot(error = TRUE, get_test_data(recipe = r, x = case_death_rate_subset)) }) @@ -39,7 +39,7 @@ test_that("expect error that geo_value or time_value does not exist", { wrong_epi_df <- case_death_rate_subset %>% dplyr::select(-geo_value) - expect_error(get_test_data(recipe = r, x = wrong_epi_df)) + expect_snapshot(error = TRUE, get_test_data(recipe = r, x = wrong_epi_df)) }) @@ -60,15 +60,15 @@ test_that("NA fill behaves as desired", { expect_silent(tt <- get_test_data(r, df)) expect_s3_class(tt, "epi_df") - expect_error(get_test_data(r, df, "A")) - expect_error(get_test_data(r, df, TRUE, -3)) + expect_snapshot(error = TRUE, get_test_data(r, df, "A")) + expect_snapshot(error = TRUE, get_test_data(r, df, TRUE, -3)) df2 <- df df2$x1[df2$geo_value == "ca"] <- NA td <- get_test_data(r, df2) expect_true(any(is.na(td))) - expect_error(get_test_data(r, df2, TRUE)) + expect_snapshot(error = TRUE, get_test_data(r, df2, TRUE)) df1 <- df2 df1$x1[1:4] <- 1:4 @@ -93,9 +93,9 @@ test_that("forecast date behaves", { step_epi_ahead(x1, ahead = 3) %>% step_epi_lag(x1, x2, lag = c(1, 3)) - expect_error(get_test_data(r, df, TRUE, forecast_date = 9)) # class error - expect_error(get_test_data(r, df, TRUE, forecast_date = 9L)) # fd too early - expect_error(get_test_data(r, df, forecast_date = 9L)) # fd too early + expect_snapshot(error = TRUE, get_test_data(r, df, TRUE, forecast_date = 9)) # class error + expect_snapshot(error = TRUE, get_test_data(r, df, TRUE, forecast_date = 9L)) # fd too early + expect_snapshot(error = TRUE, get_test_data(r, df, forecast_date = 9L)) # fd too early ndf <- get_test_data(r, df, TRUE, forecast_date = 12L) expect_equal(max(ndf$time_value), 11L) # max lag was 1 diff --git a/tests/testthat/test-layer_add_forecast_date.R b/tests/testthat/test-layer_add_forecast_date.R index 6d0e637c8..428922f46 100644 --- a/tests/testthat/test-layer_add_forecast_date.R +++ b/tests/testthat/test-layer_add_forecast_date.R @@ -11,9 +11,9 @@ latest <- jhu %>% test_that("layer validation works", { f <- frosting() - expect_error(layer_add_forecast_date(f, c("2022-05-31", "2022-05-31"))) # multiple forecast_dates - expect_error(layer_add_forecast_date(f, "2022-05-31", id = 2)) # id is not a character - expect_error(layer_add_forecast_date(f, "2022-05-31", id = c("a", "b"))) # multiple ids + expect_snapshot(error = TRUE, layer_add_forecast_date(f, c("2022-05-31", "2022-05-31"))) # multiple forecast_dates + expect_snapshot(error = TRUE, layer_add_forecast_date(f, "2022-05-31", id = 2)) # id is not a character + expect_snapshot(error = TRUE, layer_add_forecast_date(f, "2022-05-31", id = c("a", "b"))) # multiple ids expect_silent(layer_add_forecast_date(f, "2022-05-31")) expect_silent(layer_add_forecast_date(f)) expect_silent(layer_add_forecast_date(f, as.Date("2022-05-31"))) @@ -96,7 +96,7 @@ test_that("forecast date works for daily", { group_by(geo_value, time_value) %>% summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups = "drop") %>% as_epi_df() - expect_error(predict(wf1, latest_yearly)) + expect_snapshot(error = TRUE, predict(wf1, latest_yearly)) # forecast_date is a string, gets correctly converted to date wf2 <- add_frosting( @@ -110,5 +110,5 @@ test_that("forecast date works for daily", { wf, adjust_frosting(f, "layer_add_forecast_date", forecast_date = 2022L) ) - expect_error(predict(wf3, latest)) + expect_snapshot(error = TRUE, predict(wf3, latest)) }) diff --git a/tests/testthat/test-layer_add_target_date.R b/tests/testthat/test-layer_add_target_date.R index f1fa3f217..53506ad07 100644 --- a/tests/testthat/test-layer_add_target_date.R +++ b/tests/testthat/test-layer_add_target_date.R @@ -107,7 +107,7 @@ test_that("target date works for daily and yearly", { group_by(geo_value, time_value) %>% summarize(case_rate = mean(case_rate), death_rate = mean(death_rate), .groups = "drop") %>% as_epi_df() - expect_error(predict(wf1, latest_bad)) + expect_snapshot(error = TRUE, predict(wf1, latest_bad)) # target_date is a string (gets correctly converted to Date) wf1 <- add_frosting( diff --git a/tests/testthat/test-layer_predict.R b/tests/testthat/test-layer_predict.R index 041516b29..70e76e593 100644 --- a/tests/testthat/test-layer_predict.R +++ b/tests/testthat/test-layer_predict.R @@ -48,7 +48,7 @@ test_that("layer_predict dots validation", { # We don't detect completely-bogus arg names until predict time: expect_no_error(f_bad_arg <- frosting() %>% layer_predict(bogus_argument = "something")) wf_bad_arg <- wf %>% add_frosting(f_bad_arg) - expect_error(predict(wf_bad_arg, latest)) + expect_snapshot(error = TRUE, predict(wf_bad_arg, latest)) # ^ (currently with a awful error message, due to an extra comma in parsnip::check_pred_type_dots) # Some argument names only apply for some prediction `type`s; we don't check diff --git a/tests/testthat/test-layer_residual_quantiles.R b/tests/testthat/test-layer_residual_quantiles.R index e3668b249..09ef7c9d3 100644 --- a/tests/testthat/test-layer_residual_quantiles.R +++ b/tests/testthat/test-layer_residual_quantiles.R @@ -46,7 +46,7 @@ test_that("Errors when used with a classifier", { layer_predict() %>% layer_residual_quantiles() wf <- wf %>% add_frosting(f) - expect_error(forecast(wf)) + expect_snapshot(error = TRUE, forecast(wf)) }) @@ -99,8 +99,8 @@ test_that("Canned forecasters work with / without", { }) test_that("flatline_forecaster correctly errors when n_training < ahead", { - expect_error( - flatline_forecaster(jhu, "death_rate", args_list = flatline_args_list(ahead = 10, n_training = 9)), - "This may be due to `n_train` < `ahead`" + expect_snapshot( + error = TRUE, + flatline_forecaster(jhu, "death_rate", args_list = flatline_args_list(ahead = 10, n_training = 9)) ) }) diff --git a/tests/testthat/test-layers.R b/tests/testthat/test-layers.R index 13f859ac3..6e2d80111 100644 --- a/tests/testthat/test-layers.R +++ b/tests/testthat/test-layers.R @@ -11,7 +11,7 @@ test_that("A layer can be updated in frosting", { expect_equal(length(f$layers), 2) expect_equal(f$layers[[1]], fold$layers[[1]]) expect_equal(f$layers[[2]]$lower, 100) - expect_error(update(f$layers[[1]], lower = 100)) - expect_error(update(f$layers[[3]], lower = 100)) - expect_error(update(f$layers[[2]], bad_param = 100)) + expect_snapshot(error = TRUE, update(f$layers[[1]], lower = 100)) + expect_snapshot(error = TRUE, update(f$layers[[3]], lower = 100)) + expect_snapshot(error = TRUE, update(f$layers[[2]], bad_param = 100)) }) diff --git a/tests/testthat/test-parse_period.R b/tests/testthat/test-parse_period.R index 0adbcec3d..10dd5692d 100644 --- a/tests/testthat/test-parse_period.R +++ b/tests/testthat/test-parse_period.R @@ -1,8 +1,8 @@ test_that("parse_period works", { - expect_error(parse_period(c(1, 2))) - expect_error(parse_period(c(1.3))) - expect_error(parse_period("1 year")) - expect_error(parse_period("2 weeks later")) + expect_snapshot(error = TRUE, parse_period(c(1, 2))) + expect_snapshot(error = TRUE, parse_period(c(1.3))) + expect_snapshot(error = TRUE, parse_period("1 year")) + expect_snapshot(error = TRUE, parse_period("2 weeks later")) expect_identical(parse_period(1), 1L) expect_identical(parse_period("1 day"), 1L) expect_identical(parse_period("1 days"), 1L) diff --git a/tests/testthat/test-parsnip_model_validation.R b/tests/testthat/test-parsnip_model_validation.R index 02ed94fe0..605fad817 100644 --- a/tests/testthat/test-parsnip_model_validation.R +++ b/tests/testthat/test-parsnip_model_validation.R @@ -4,12 +4,12 @@ test_that("forecaster can validate parsnip model", { trainer2 <- parsnip::logistic_reg() trainer3 <- parsnip::rand_forest() - expect_error(get_parsnip_mode(l)) + expect_snapshot(error = TRUE, get_parsnip_mode(l)) expect_equal(get_parsnip_mode(trainer1), "regression") expect_equal(get_parsnip_mode(trainer2), "classification") expect_equal(get_parsnip_mode(trainer3), "unknown") - expect_error(is_classification(l)) + expect_snapshot(error = TRUE, is_classification(l)) expect_true(is_regression(trainer1)) expect_false(is_classification(trainer1)) expect_true(is_classification(trainer2)) diff --git a/tests/testthat/test-pivot_quantiles.R b/tests/testthat/test-pivot_quantiles.R index d1f092c0e..1639058e2 100644 --- a/tests/testthat/test-pivot_quantiles.R +++ b/tests/testthat/test-pivot_quantiles.R @@ -1,14 +1,14 @@ test_that("quantile pivotting wider behaves", { tib <- tibble::tibble(a = 1:5, b = 6:10) - expect_error(pivot_quantiles_wider(tib, a)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, a)) tib$c <- rep(dist_normal(), 5) - expect_error(pivot_quantiles_wider(tib, c)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, c)) d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:5, 1:4 / 5)) # different quantiles tib <- tib[1:2, ] tib$d1 <- d1 - expect_error(pivot_quantiles_wider(tib, d1)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, d1)) d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 2:4 / 4)) tib$d1 <- d1 @@ -36,9 +36,9 @@ test_that("pivotting wider still works if there are duplicates", { test_that("quantile pivotting longer behaves", { tib <- tibble::tibble(a = 1:5, b = 6:10) - expect_error(pivot_quantiles_longer(tib, a)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, a)) tib$c <- rep(dist_normal(), 5) - expect_error(pivot_quantiles_longer(tib, c)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, c)) d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:5, 1:4 / 5)) # different quantiles @@ -64,7 +64,7 @@ test_that("quantile pivotting longer behaves", { tib$d3 <- c(dist_quantiles(2:5, 2:5 / 6), dist_quantiles(3:6, 2:5 / 6)) # now the cols have different numbers of quantiles - expect_error(pivot_quantiles_longer(tib, d1, d3)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, d1, d3)) expect_length( pivot_quantiles_longer(tib, d1, d3, .ignore_length_check = TRUE), 6L diff --git a/tests/testthat/test-population_scaling.R b/tests/testthat/test-population_scaling.R index a94b40b82..6337a2ea8 100644 --- a/tests/testthat/test-population_scaling.R +++ b/tests/testthat/test-population_scaling.R @@ -279,7 +279,8 @@ test_that("expect error if `by` selector does not match", { df_pop_col = "values" ) - expect_error( + expect_snapshot( + error = TRUE, wf <- epi_workflow(r, parsnip::linear_reg()) %>% fit(jhu) %>% add_frosting(f) @@ -311,7 +312,7 @@ test_that("expect error if `by` selector does not match", { fit(jhu) %>% add_frosting(f) - expect_error(forecast(wf)) + expect_snapshot(error = TRUE, forecast(wf)) }) diff --git a/tests/testthat/test-shuffle.R b/tests/testthat/test-shuffle.R index 94bc1aa3b..f05e8be3d 100644 --- a/tests/testthat/test-shuffle.R +++ b/tests/testthat/test-shuffle.R @@ -1,5 +1,5 @@ test_that("shuffle works", { - expect_error(shuffle(matrix(NA, 2, 2))) + expect_snapshot(error = TRUE, shuffle(matrix(NA, 2, 2))) expect_length(shuffle(1:10), 10L) expect_identical(sort(shuffle(1:10)), 1:10) }) diff --git a/tests/testthat/test-step_epi_slide.R b/tests/testthat/test-step_epi_slide.R index c1e72501d..27f362ad6 100644 --- a/tests/testthat/test-step_epi_slide.R +++ b/tests/testthat/test-step_epi_slide.R @@ -31,6 +31,8 @@ test_that("epi_slide errors when needed", { # function problems expect_snapshot(error = TRUE, r %>% step_epi_slide(value)) expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = 1)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value)) + expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = 1)) }) diff --git a/tests/testthat/test-wis-dist-quantiles.R b/tests/testthat/test-wis-dist-quantiles.R index 93f7c50eb..937793189 100644 --- a/tests/testthat/test-wis-dist-quantiles.R +++ b/tests/testthat/test-wis-dist-quantiles.R @@ -26,7 +26,7 @@ test_that("wis dispatches and produces the correct values", { ) # errors for non distributions - expect_error(weighted_interval_score(1:10, 10)) + expect_snapshot(error = TRUE, weighted_interval_score(1:10, 10)) expect_warning(w <- weighted_interval_score(dist_normal(1), 10)) expect_true(all(is.na(w))) expect_warning(w <- weighted_interval_score( @@ -36,7 +36,7 @@ test_that("wis dispatches and produces the correct values", { expect_equal(w, c(NA, wis_one_pred(1:5, 1:5 / 6, 10))) # errors if sizes don't match - expect_error(weighted_interval_score( + expect_snapshot(error = TRUE, weighted_interval_score( dist_quantiles(list(1:4, 8:11), 1:4 / 5), # length 2 1:3 )) From b74c039c2881d7bc772935b34de1288e9d03a597 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Mon, 30 Sep 2024 16:12:09 -0700 Subject: [PATCH 26/37] skeleton --- DESCRIPTION | 2 +- NAMESPACE | 25 +-- R/dist_quantiles.R | 254 ++++----------------------- man/dist_quantiles.Rd | 37 ---- tests/testthat/test-dist_quantiles.R | 42 ++--- 5 files changed, 53 insertions(+), 307 deletions(-) delete mode 100644 man/dist_quantiles.Rd diff --git a/DESCRIPTION b/DESCRIPTION index d0366f22b..0aaa3afe6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,7 +34,7 @@ Imports: generics, ggplot2, glue, - hardhat (>= 1.3.0), + hardhat (>= 1.4.0.9002), magrittr, recipes (>= 1.0.4), rlang (>= 1.0.0), diff --git a/NAMESPACE b/NAMESPACE index c20b8c801..c4ad20cfa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,8 +2,6 @@ S3method(Add_model,epi_workflow) S3method(Add_model,workflow) -S3method(Math,dist_quantiles) -S3method(Ops,dist_quantiles) S3method(Remove_model,epi_workflow) S3method(Remove_model,workflow) S3method(Update_model,epi_workflow) @@ -45,13 +43,9 @@ S3method(fit,epi_workflow) S3method(flusight_hub_formatter,canned_epipred) S3method(flusight_hub_formatter,data.frame) S3method(forecast,epi_workflow) -S3method(format,dist_quantiles) -S3method(is.na,dist_quantiles) -S3method(is.na,distribution) S3method(key_colnames,epi_workflow) S3method(key_colnames,recipe) -S3method(mean,dist_quantiles) -S3method(median,dist_quantiles) +S3method(mean,quantile_pred) S3method(predict,epi_workflow) S3method(predict,flatline) S3method(prep,check_enough_train_data) @@ -93,7 +87,7 @@ S3method(print,step_lag_difference) S3method(print,step_naomit) S3method(print,step_population_scaling) S3method(print,step_training_window) -S3method(quantile,dist_quantiles) +S3method(quantile,quantile_pred) S3method(recipe,epi_df) S3method(recipes::recipe,formula) S3method(refresh_blueprint,default_epi_recipe_blueprint) @@ -119,8 +113,6 @@ S3method(tidy,check_enough_train_data) S3method(tidy,frosting) S3method(tidy,layer) S3method(update,layer) -S3method(vec_ptype_abbr,dist_quantiles) -S3method(vec_ptype_full,dist_quantiles) S3method(weighted_interval_score,default) S3method(weighted_interval_score,dist_default) S3method(weighted_interval_score,dist_quantiles) @@ -150,7 +142,6 @@ export(check_enough_train_data) export(clean_f_name) export(default_epi_recipe_blueprint) export(detect_layer) -export(dist_quantiles) export(epi_recipe) export(epi_workflow) export(extract_argument) @@ -208,7 +199,6 @@ export(update_frosting) export(update_model) export(validate_layer) export(weighted_interval_score) -import(distributional) import(epiprocess) import(parsnip) import(recipes) @@ -283,24 +273,13 @@ importFrom(rlang,is_true) importFrom(rlang,set_names) importFrom(rlang,sym) importFrom(stats,as.formula) -importFrom(stats,family) importFrom(stats,lm) -importFrom(stats,median) importFrom(stats,model.frame) importFrom(stats,poly) importFrom(stats,predict) -importFrom(stats,qnorm) importFrom(stats,quantile) importFrom(stats,residuals) importFrom(tibble,as_tibble) importFrom(tibble,tibble) importFrom(tidyr,crossing) -importFrom(vctrs,as_list_of) -importFrom(vctrs,field) -importFrom(vctrs,new_rcrd) -importFrom(vctrs,new_vctr) -importFrom(vctrs,vec_cast) importFrom(vctrs,vec_data) -importFrom(vctrs,vec_ptype_abbr) -importFrom(vctrs,vec_ptype_full) -importFrom(vctrs,vec_recycle_common) diff --git a/R/dist_quantiles.R b/R/dist_quantiles.R index dd97ec809..bf32c35ec 100644 --- a/R/dist_quantiles.R +++ b/R/dist_quantiles.R @@ -1,204 +1,68 @@ -#' @importFrom vctrs field vec_cast new_rcrd -new_quantiles <- function(values = double(1), quantile_levels = double(1)) { - arg_is_probabilities(quantile_levels) - - vec_cast(values, double()) - vec_cast(quantile_levels, double()) - values <- unname(values) - if (length(values) == 0L) { - return(new_rcrd( - list( - values = rep(NA_real_, length(quantile_levels)), - quantile_levels = quantile_levels - ), - class = c("dist_quantiles", "dist_default") - )) - } - stopifnot(length(values) == length(quantile_levels)) - - stopifnot(!vctrs::vec_duplicate_any(quantile_levels)) - if (is.unsorted(quantile_levels)) { - o <- vctrs::vec_order(quantile_levels) - values <- values[o] - quantile_levels <- quantile_levels[o] - } - if (is.unsorted(values, na.rm = TRUE)) { - cli::cli_abort("`values[order(quantile_levels)]` produces unsorted quantiles.") - } - - new_rcrd(list(values = values, quantile_levels = quantile_levels), - class = c("dist_quantiles", "dist_default") - ) -} - - - -#' @importFrom vctrs vec_ptype_abbr vec_ptype_full -#' @export -vec_ptype_abbr.dist_quantiles <- function(x, ...) "dist_qntls" -#' @export -vec_ptype_full.dist_quantiles <- function(x, ...) "dist_quantiles" - -#' @export -format.dist_quantiles <- function(x, digits = 2, ...) { - m <- suppressWarnings(median(x)) - paste0("quantiles(", round(m, digits), ")[", vctrs::vec_size(x), "]") -} - - -#' A distribution parameterized by a set of quantiles -#' -#' @param values A vector (or list of vectors) of values. -#' @param quantile_levels A vector (or list of vectors) of probabilities -#' corresponding to `values`. -#' -#' When creating multiple sets of `values`/`quantile_levels` resulting in -#' different distributions, the sizes must match. See the examples below. -#' -#' @return A vector of class `"distribution"`. -#' -#' @export -#' -#' @examples -#' dist_quantiles(1:4, 1:4 / 5) -#' dist_quantiles(list(1:3, 1:4), list(1:3 / 4, 1:4 / 5)) -#' dstn <- dist_quantiles(list(1:4, 8:11), c(.2, .4, .6, .8)) -#' dstn -#' -#' quantile(dstn, p = c(.1, .25, .5, .9)) -#' median(dstn) -#' -#' # it's a bit annoying to inspect the data -#' distributional::parameters(dstn[1]) -#' nested_quantiles(dstn[1])[[1]] -#' -#' @importFrom vctrs as_list_of vec_recycle_common new_vctr -dist_quantiles <- function(values, quantile_levels) { - if (!is.list(quantile_levels)) { - assert_numeric(quantile_levels, lower = 0, upper = 1, any.missing = FALSE, min.len = 1L) - quantile_levels <- list(quantile_levels) - } - if (!is.list(values)) { - if (length(values) == 0L) values <- NA_real_ - values <- list(values) - } - - values <- as_list_of(values, .ptype = double()) - quantile_levels <- as_list_of(quantile_levels, .ptype = double()) - args <- vec_recycle_common(values = values, quantile_levels = quantile_levels) - - qntls <- as_list_of( - map2(args$values, args$quantile_levels, new_quantiles), - .ptype = new_quantiles(NA_real_, 0.5) - ) - new_vctr(qntls, class = "distribution") -} - -validate_dist_quantiles <- function(values, quantile_levels) { - map(quantile_levels, arg_is_probabilities) - common_length <- vctrs::vec_size_common( # aborts internally - values = values, - quantile_levels = quantile_levels - ) - length_diff <- vctrs::list_sizes(values) != vctrs::list_sizes(quantile_levels) - if (any(length_diff)) { - cli::cli_abort(c( - "`values` and `quantile_levels` must have common length.", - i = "Mismatches found at position(s): {.val {which(length_diff)}}." - )) - } - level_duplication <- map_lgl(quantile_levels, vctrs::vec_duplicate_any) - if (any(level_duplication)) { - cli::cli_abort(c( - "`quantile_levels` must not be duplicated.", - i = "Duplicates found at position(s): {.val {which(level_duplication)}}." - )) - } -} - - -is_dist_quantiles <- function(x) { - is_distribution(x) & all(stats::family(x) == "quantiles") -} - - - -#' @export -#' @importFrom stats median qnorm family -median.dist_quantiles <- function(x, na.rm = FALSE, ..., middle = c("cubic", "linear")) { - quantile_levels <- field(x, "quantile_levels") - values <- field(x, "values") - if (0.5 %in% quantile_levels) { - return(values[match(0.5, quantile_levels)]) - } - if (length(quantile_levels) < 2 || min(quantile_levels) > 0.5 || max(quantile_levels) < 0.5) { - return(NA) - } - if (length(quantile_levels) < 3 || min(quantile_levels) > .25 || max(quantile_levels) < .75) { - return(stats::approx(quantile_levels, values, xout = 0.5)$y) - } - quantile(x, 0.5, ..., middle = middle) -} # placeholder to avoid errors, but not ideal #' @export -mean.dist_quantiles <- function(x, na.rm = FALSE, ..., middle = c("cubic", "linear")) { - median(x, ..., middle = middle) +mean.quantile_pred <- function(x, na.rm = FALSE, ...) { + median(x, ...) } #' @export #' @importFrom stats quantile -#' @import distributional -quantile.dist_quantiles <- function(x, p, ..., middle = c("cubic", "linear")) { +quantile.quantile_pred <- function(x, p, ..., middle = c("cubic", "linear")) { arg_is_probabilities(p) p <- sort(p) - middle <- match.arg(middle) + middle <- rlang::arg_match(middle) quantile_extrapolate(x, p, middle) } quantile_extrapolate <- function(x, tau_out, middle) { - tau <- field(x, "quantile_levels") - qvals <- field(x, "values") - nas <- is.na(qvals) - qvals_out <- rep(NA, length(tau_out)) - qvals <- qvals[!nas] - tau <- tau[!nas] + tau <- x %@% "quantile_levels" + qvals <- as.matrix(x) # short circuit if we aren't actually extrapolating # matches to ~15 decimals if (all(tau_out %in% tau)) { - return(qvals[match(tau_out, tau)]) + return(hardhat::quantile_pred( + qvals[ ,match(tau_out, tau), drop = FALSE], tau_out + )) } if (length(tau) < 2) { - cli::cli_abort( - "Quantile extrapolation is not possible with fewer than 2 quantiles." - ) - return(qvals_out) + cli_abort(paste( + "Quantile extrapolation is not possible when fewer than 2 quantiles", + "are available." + )) } + qvals_out <- map( + vctrs::vec_chop(qvals), + ~ extrapolate_quantiles_single(.x, tau, tau_out, middle) + ) + hardhat::quantile_pred(qvals_out, tau_out) +} + +extrapolate_quantiles_single <- function(qvals, tau, tau_out, middle) { indl <- tau_out < min(tau) indr <- tau_out > max(tau) indm <- !indl & !indr + qvals_out <- rep(NA, length(tau_out)) if (middle == "cubic") { method <- "cubic" - result <- tryCatch( - { - Q <- stats::splinefun(tau, qvals, method = "hyman") - quartiles <- Q(c(.25, .5, .75)) - }, - error = function(e) { - return(NA) - } - ) + result <- tryCatch({ + Q <- stats::splinefun(tau, qvals, method = "hyman") + quartiles <- Q(c(.25, .5, .75)) + }, + error = function(e) { + return(NA) + }) } if (middle == "linear" || any(is.na(result))) { method <- "linear" quartiles <- stats::approx(tau, qvals, c(.25, .5, .75))$y } if (any(indm)) { - qvals_out[indm] <- switch(method, + qvals_out[indm] <- switch( + method, linear = stats::approx(tau, qvals, tau_out[indm])$y, cubic = Q(tau_out[indm]) ) @@ -237,59 +101,3 @@ tail_extrapolate <- function(tau_out, qv) { m <- diff(y) / diff(x) m * (x0 - x[1]) + y[1] } - - -#' @method Math dist_quantiles -#' @export -Math.dist_quantiles <- function(x, ...) { - quantile_levels <- field(x, "quantile_levels") - values <- field(x, "values") - values <- vctrs::vec_math(.Generic, values, ...) - new_quantiles(values = values, quantile_levels = quantile_levels) -} - -#' @method Ops dist_quantiles -#' @export -Ops.dist_quantiles <- function(e1, e2) { - is_quantiles <- c( - inherits(e1, "dist_quantiles"), - inherits(e2, "dist_quantiles") - ) - is_dist <- c(inherits(e1, "dist_default"), inherits(e2, "dist_default")) - tau1 <- tau2 <- NULL - if (is_quantiles[1]) { - q1 <- field(e1, "values") - tau1 <- field(e1, "quantile_levels") - } - if (is_quantiles[2]) { - q2 <- field(e2, "values") - tau2 <- field(e2, "quantile_levels") - } - tau <- union(tau1, tau2) - if (all(is_dist)) { - cli::cli_abort( - "You can't perform arithmetic between two distributions like this." - ) - } else { - if (is_quantiles[1]) { - q2 <- e2 - } else { - q1 <- e1 - } - } - q <- vctrs::vec_arith(.Generic, q1, q2) - new_quantiles(values = q, quantile_levels = tau) -} - -#' @method is.na distribution -#' @export -is.na.distribution <- function(x) { - sapply(vec_data(x), is.na) -} - -#' @method is.na dist_quantiles -#' @export -is.na.dist_quantiles <- function(x) { - q <- field(x, "values") - all(is.na(q)) -} diff --git a/man/dist_quantiles.Rd b/man/dist_quantiles.Rd deleted file mode 100644 index 1a3226e36..000000000 --- a/man/dist_quantiles.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dist_quantiles.R -\name{dist_quantiles} -\alias{dist_quantiles} -\title{A distribution parameterized by a set of quantiles} -\usage{ -dist_quantiles(values, quantile_levels) -} -\arguments{ -\item{values}{A vector (or list of vectors) of values.} - -\item{quantile_levels}{A vector (or list of vectors) of probabilities -corresponding to \code{values}. - -When creating multiple sets of \code{values}/\code{quantile_levels} resulting in -different distributions, the sizes must match. See the examples below.} -} -\value{ -A vector of class \code{"distribution"}. -} -\description{ -A distribution parameterized by a set of quantiles -} -\examples{ -dist_quantiles(1:4, 1:4 / 5) -dist_quantiles(list(1:3, 1:4), list(1:3 / 4, 1:4 / 5)) -dstn <- dist_quantiles(list(1:4, 8:11), c(.2, .4, .6, .8)) -dstn - -quantile(dstn, p = c(.1, .25, .5, .9)) -median(dstn) - -# it's a bit annoying to inspect the data -distributional::parameters(dstn[1]) -nested_quantiles(dstn[1])[[1]] - -} diff --git a/tests/testthat/test-dist_quantiles.R b/tests/testthat/test-dist_quantiles.R index 66456ef80..4b20aa6b9 100644 --- a/tests/testthat/test-dist_quantiles.R +++ b/tests/testthat/test-dist_quantiles.R @@ -1,36 +1,32 @@ -library(distributional) -test_that("constructor returns reasonable quantiles", { - expect_error(new_quantiles(rnorm(5), rnorm(5))) - expect_silent(new_quantiles(sort(rnorm(5)), sort(runif(5)))) - expect_error(new_quantiles(sort(rnorm(5)), sort(runif(2)))) - expect_silent(new_quantiles(1:5, 1:5 / 10)) - expect_error(new_quantiles(c(2, 1, 3, 4, 5), c(.1, .1, .2, .5, .8))) - expect_error(new_quantiles(c(2, 1, 3, 4, 5), c(.1, .15, .2, .5, .8))) - expect_error(new_quantiles(c(1, 2, 3), c(.1, .2, 3))) -}) - - -test_that("single dist_quantiles works, quantiles are accessible", { - z <- new_quantiles(values = 1:5, quantile_levels = c(.2, .4, .5, .6, .8)) - expect_s3_class(z, "dist_quantiles") +test_that("single quantile_pred works, quantiles are accessible", { + z <- hardhat::quantile_pred( + values = matrix(1:5, nrow = 1), + quantile_levels = c(.2, .4, .5, .6, .8) + ) expect_equal(median(z), 3) - expect_equal(quantile(z, c(.2, .4, .5, .6, .8)), 1:5) - expect_equal(quantile(z, c(.3, .7), middle = "linear"), c(1.5, 4.5)) + expect_equal( + quantile(z, c(.2, .4, .5, .6, .8)), + hardhat::quantile_pred(matrix(1:5, nrow = 1), c(.2, .4, .5, .6, .8)) + ) + expect_equal( + quantile(z, c(.3, .7), middle = "linear"), + hardhat::quantile_pred(matrix(c(1.5, 4.5), nrow = 1), c(.3, .7)) + ) Q <- stats::splinefun(c(.2, .4, .5, .6, .8), 1:5, method = "hyman") expect_equal(quantile(z, c(.3, .7), middle = "cubic"), Q(c(.3, .7))) expect_identical( extrapolate_quantiles(z, c(.3, .7), middle = "linear"), - new_quantiles(values = c(1, 1.5, 2, 3, 4, 4.5, 5), quantile_levels = 2:8 / 10) + hardhat::quantile_pred(c(1, 1.5, 2, 3, 4, 4.5, 5), 2:8 / 10) ) # empty values slot results in a length zero distribution # see issue #361 - expect_length(dist_quantiles(list(), c(.1, .9)), 0L) - expect_identical( - dist_quantiles(list(), c(.1, .9)), - distributional::dist_degenerate(double()) - ) + # expect_length(dist_quantiles(list(), c(.1, .9)), 0L) + # expect_identical( + # dist_quantiles(list(), c(.1, .9)), + # distributional::dist_degenerate(double()) + # ) }) From aa418276c345319360eacabd1e6c9e9aa6e2305e Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Mon, 30 Sep 2024 16:24:26 -0700 Subject: [PATCH 27/37] bump version, promote authors, add funder --- DESCRIPTION | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c76280d45..5cd468fb9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,13 +1,14 @@ Package: epipredict Title: Basic epidemiology forecasting methods -Version: 0.0.24 +Version: 0.1.0 Authors@R: c( - person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), + person("Daniel J.", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")), person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"), + person("Dmitry", "Shemetov", email = "dshemeto@andrew.cmu.edu", role = "aut"), + person("David", "Weber", email = "davidweb@andrew.cmu.edu", role = "aut"), + person("CMU's Delphi Research Group", role = c("cph", "fnd")), person("Logan", "Brooks", role = "aut"), person("Rachel", "Lobay", role = "aut"), - person("Dmitry", "Shemetov", email = "dshemeto@andrew.cmu.edu", role = "ctb"), - person("David", "Weber", email = "davidweb@andrew.cmu.edu", role = "ctb"), person("Maggie", "Liu", role = "ctb"), person("Ken", "Mawer", role = "ctb"), person("Chloe", "You", role = "ctb"), From 7ee015a792bae9a4adfce7e947ca43d37268a736 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 09:02:26 -0700 Subject: [PATCH 28/37] add math ops, test --- NAMESPACE | 12 ++- R/extrapolate_quantiles.R | 40 ++++----- ...st_quantiles.R => quantile_pred-methods.R} | 75 ++++++++++++++--- tests/testthat/test-dist_quantiles.R | 82 +++++++++---------- 4 files changed, 130 insertions(+), 79 deletions(-) rename R/{dist_quantiles.R => quantile_pred-methods.R} (52%) diff --git a/NAMESPACE b/NAMESPACE index c4ad20cfa..8e071fa8a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,9 +36,7 @@ S3method(extract_frosting,default) S3method(extract_frosting,epi_workflow) S3method(extract_layers,frosting) S3method(extract_layers,workflow) -S3method(extrapolate_quantiles,dist_default) -S3method(extrapolate_quantiles,dist_quantiles) -S3method(extrapolate_quantiles,distribution) +S3method(extrapolate_quantiles,quantile_pred) S3method(fit,epi_workflow) S3method(flusight_hub_formatter,canned_epipred) S3method(flusight_hub_formatter,data.frame) @@ -113,6 +111,10 @@ S3method(tidy,check_enough_train_data) S3method(tidy,frosting) S3method(tidy,layer) S3method(update,layer) +S3method(vec_arith,quantile_pred) +S3method(vec_arith.numeric,quantile_pred) +S3method(vec_arith.quantile_pred,numeric) +S3method(vec_math,quantile_pred) S3method(weighted_interval_score,default) S3method(weighted_interval_score,dist_default) S3method(weighted_interval_score,dist_quantiles) @@ -282,4 +284,6 @@ importFrom(stats,residuals) importFrom(tibble,as_tibble) importFrom(tibble,tibble) importFrom(tidyr,crossing) -importFrom(vctrs,vec_data) +importFrom(vctrs,vec_arith) +importFrom(vctrs,vec_arith.numeric) +importFrom(vctrs,vec_math) diff --git a/R/extrapolate_quantiles.R b/R/extrapolate_quantiles.R index 3362e339e..d9e899ef6 100644 --- a/R/extrapolate_quantiles.R +++ b/R/extrapolate_quantiles.R @@ -32,34 +32,28 @@ extrapolate_quantiles <- function(x, probs, replace_na = TRUE, ...) { } #' @export -#' @importFrom vctrs vec_data -extrapolate_quantiles.distribution <- function(x, probs, replace_na = TRUE, ...) { - rlang::check_dots_empty() +extrapolate_quantiles.quantile_pred <- function(x, probs, replace_na = TRUE, ...) { arg_is_lgl_scalar(replace_na) arg_is_probabilities(probs) if (is.unsorted(probs)) probs <- sort(probs) - dstn <- lapply(vec_data(x), extrapolate_quantiles, probs = probs, replace_na = replace_na) - new_vctr(dstn, vars = NULL, class = "distribution") -} - -#' @export -extrapolate_quantiles.dist_default <- function(x, probs, replace_na = TRUE, ...) { - values <- quantile(x, probs, ...) - new_quantiles(values = values, quantile_levels = probs) -} + orig_probs <- x %@% "quantile_levels" + orig_values <- as.matrix(x) -#' @export -extrapolate_quantiles.dist_quantiles <- function(x, probs, replace_na = TRUE, ...) { - orig_probs <- field(x, "quantile_levels") - orig_values <- field(x, "values") - new_probs <- c(orig_probs, probs) - dups <- duplicated(new_probs) if (!replace_na || !anyNA(orig_values)) { - new_values <- c(orig_values, quantile(x, probs, ...)) + all_values <- cbind(orig_values, quantile(x, probs, ...)) } else { - nas <- is.na(orig_values) - orig_values[nas] <- quantile(x, orig_probs[nas], ...) - new_values <- c(orig_values, quantile(x, probs, ...)) + newx <- quantile(x, orig_probs, ...) %>% + hardhat::quantile_pred(orig_probs) + all_values <- cbind(as.matrix(newx), quantile(newx, probs, ...)) } - new_quantiles(new_values[!dups], new_probs[!dups]) + all_probs <- c(orig_probs, probs) + dups <- duplicated(all_probs) + all_values <- all_values[, !dups, drop = FALSE] + all_probs <- all_probs[!dups] + o <- order(all_probs) + + hardhat::quantile_pred( + all_values[, o, drop = FALSE], + quantile_levels = all_probs[o] + ) } diff --git a/R/dist_quantiles.R b/R/quantile_pred-methods.R similarity index 52% rename from R/dist_quantiles.R rename to R/quantile_pred-methods.R index bf32c35ec..04884ccd0 100644 --- a/R/dist_quantiles.R +++ b/R/quantile_pred-methods.R @@ -5,26 +5,29 @@ mean.quantile_pred <- function(x, na.rm = FALSE, ...) { median(x, ...) } + +# quantiles by treating quantile_pred like a distribution ----------------- + + #' @export #' @importFrom stats quantile -quantile.quantile_pred <- function(x, p, ..., middle = c("cubic", "linear")) { +quantile.quantile_pred <- function(x, p, na.rm = FALSE, ..., + middle = c("cubic", "linear")) { arg_is_probabilities(p) p <- sort(p) middle <- rlang::arg_match(middle) - quantile_extrapolate(x, p, middle) + quantile_internal(x, p, middle) } -quantile_extrapolate <- function(x, tau_out, middle) { +quantile_internal <- function(x, tau_out, middle) { tau <- x %@% "quantile_levels" qvals <- as.matrix(x) # short circuit if we aren't actually extrapolating # matches to ~15 decimals - if (all(tau_out %in% tau)) { - return(hardhat::quantile_pred( - qvals[ ,match(tau_out, tau), drop = FALSE], tau_out - )) + if (all(tau_out %in% tau) && !anyNA(qvals)) { + return(qvals[ , match(tau_out, tau), drop = FALSE]) } if (length(tau) < 2) { cli_abort(paste( @@ -36,15 +39,26 @@ quantile_extrapolate <- function(x, tau_out, middle) { vctrs::vec_chop(qvals), ~ extrapolate_quantiles_single(.x, tau, tau_out, middle) ) - - hardhat::quantile_pred(qvals_out, tau_out) + qvals_out <- do.call(rbind, qvals_out) # ensure a matrix of the proper dims + qvals_out } extrapolate_quantiles_single <- function(qvals, tau, tau_out, middle) { + qvals_out <- rep(NA, length(tau_out)) + good <- !is.na(qvals) + qvals <- qvals[good] + tau <- tau[good] + + # in case we only have one point, and it matches something we wanted + if (length(good) < 2) { + matched_one <- tau_out %in% tau + qvals_out[matched_one] <- qvals[matched_one] + return(qvals_out) + } + indl <- tau_out < min(tau) indr <- tau_out > max(tau) indm <- !indl & !indr - qvals_out <- rep(NA, length(tau_out)) if (middle == "cubic") { method <- "cubic" @@ -101,3 +115,44 @@ tail_extrapolate <- function(tau_out, qv) { m <- diff(y) / diff(x) m * (x0 - x[1]) + y[1] } + + +# mathematical operations on the values ----------------------------------- + + +#' @importFrom vctrs vec_math +#' @export +#' @method vec_math quantile_pred +vec_math.quantile_pred <- function(.fn, .x, ...) { + fn <- .fn + .fn <- getExportedValue("base", .fn) + if (fn %in% c("any", "all", "prod", "sum", "cumsum", "cummax", "cummin", "cumprod")) { + cli_abort("{.fn {fn}} is not a supported operation for {.cls quantile_pred}.") + } + quantile_levels <- .x %@% "quantile_levels" + .x <- as.matrix(.x) + hardhat::quantile_pred(.fn(.x), quantile_levels) +} + +#' @importFrom vctrs vec_arith vec_arith.numeric +#' @export +#' @method vec_arith quantile_pred +vec_arith.quantile_pred <- function(op, x, y, ...) { + UseMethod("vec_arith.quantile_pred", y) +} + +#' @export +#' @method vec_arith.quantile_pred numeric +vec_arith.quantile_pred.numeric <- function(op, x, y, ...) { + op_fn <- getExportedValue("base", op) + out <- op_fn(as.matrix(x), y) + hardhat::quantile_pred(out, x %@% "quantile_levels") +} + +#' @export +#' @method vec_arith.numeric quantile_pred +vec_arith.numeric.quantile_pred <- function(op, x, y, ...) { + op_fn <- getExportedValue("base", op) + out <- op_fn(x, as.matrix(y)) + hardhat::quantile_pred(out, y %@% "quantile_levels") +} diff --git a/tests/testthat/test-dist_quantiles.R b/tests/testthat/test-dist_quantiles.R index 4b20aa6b9..18fe92ed2 100644 --- a/tests/testthat/test-dist_quantiles.R +++ b/tests/testthat/test-dist_quantiles.R @@ -5,52 +5,38 @@ test_that("single quantile_pred works, quantiles are accessible", { quantile_levels = c(.2, .4, .5, .6, .8) ) expect_equal(median(z), 3) - expect_equal( - quantile(z, c(.2, .4, .5, .6, .8)), - hardhat::quantile_pred(matrix(1:5, nrow = 1), c(.2, .4, .5, .6, .8)) - ) + expect_equal(quantile(z, c(.2, .4, .5, .6, .8)), matrix(1:5, nrow = 1)) expect_equal( quantile(z, c(.3, .7), middle = "linear"), - hardhat::quantile_pred(matrix(c(1.5, 4.5), nrow = 1), c(.3, .7)) + matrix(c(1.5, 4.5), nrow = 1) ) Q <- stats::splinefun(c(.2, .4, .5, .6, .8), 1:5, method = "hyman") - expect_equal(quantile(z, c(.3, .7), middle = "cubic"), Q(c(.3, .7))) + expect_equal(quantile(z, c(.3, .7)), Q(c(.3, .7))) expect_identical( extrapolate_quantiles(z, c(.3, .7), middle = "linear"), - hardhat::quantile_pred(c(1, 1.5, 2, 3, 4, 4.5, 5), 2:8 / 10) + hardhat::quantile_pred(matrix(c(1, 1.5, 2, 3, 4, 4.5, 5), nrow = 1), 2:8 / 10) ) - # empty values slot results in a length zero distribution - # see issue #361 - # expect_length(dist_quantiles(list(), c(.1, .9)), 0L) - # expect_identical( - # dist_quantiles(list(), c(.1, .9)), - # distributional::dist_degenerate(double()) - # ) }) test_that("quantile extrapolator works", { - dstn <- dist_normal(c(10, 2), c(5, 10)) - qq <- extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) - expect_s3_class(qq, "distribution") - expect_s3_class(vctrs::vec_data(qq[1])[[1]], "dist_quantiles") - expect_length(parameters(qq[1])$quantile_levels[[1]], 3L) - - dstn <- dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) + dstn <- hardhat::quantile_pred( + matrix(c(1:4, 8:11), nrow = 2, byrow = TRUE), + c(.2, .4, .6, .8) + ) qq <- extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) - expect_s3_class(qq, "distribution") - expect_s3_class(vctrs::vec_data(qq[1])[[1]], "dist_quantiles") - expect_length(parameters(qq[1])$quantile_levels[[1]], 7L) + expect_s3_class(qq, c("quantile_pred", "vctrs_vctr", "list")) + expect_length(qq %@% "quantile_levels", 7L) - dstn <- dist_quantiles(1:4, 1:4 / 5) + dstn <- hardhat::quantile_pred(matrix(1:4, nrow = 1), 1:4 / 5) qq <- extrapolate_quantiles(dstn, 1:9 / 10) - dstn_na <- dist_quantiles(c(1, 2, NA, 4), 1:4 / 5) + dstn_na <- hardhat::quantile_pred(matrix(c(1, 2, NA, 4), nrow = 1), 1:4 / 5) qq2 <- extrapolate_quantiles(dstn_na, 1:9 / 10) expect_equal(qq, qq2) qq3 <- extrapolate_quantiles(dstn_na, 1:9 / 10, replace_na = FALSE) - qq2_vals <- field(vec_data(qq2)[[1]], "values") - qq3_vals <- field(vec_data(qq3)[[1]], "values") + qq2_vals <- unlist(qq2) + qq3_vals <- unlist(qq3) qq2_vals[6] <- NA expect_equal(qq2_vals, qq3_vals) }) @@ -60,7 +46,7 @@ test_that("small deviations of quantile requests work", { v <- c(0.0890306, 0.1424997, 0.1971793, 0.2850978, 0.3832912, 0.4240479) badl <- l badl[1] <- badl[1] - 1e-14 - distn <- dist_quantiles(list(v), list(l)) + distn <- hardhat::quantile_pred(matrix(v, nrow = 1), l) # was broken before, now works expect_equal(quantile(distn, l), quantile(distn, badl)) @@ -69,39 +55,51 @@ test_that("small deviations of quantile requests work", { # the smallest (largest) values or we could end up unsorted l <- 1:9 / 10 v <- 1:9 - distn <- dist_quantiles(list(v), list(l)) - expect_equal(quantile(distn, c(.25, .75)), list(c(2.5, 7.5))) - expect_equal(quantile(distn, c(.1, .9)), list(c(1, 9))) + distn <- hardhat::quantile_pred(matrix(v, nrow = 1), l) + expect_equal(quantile(distn, c(.25, .75)), matrix(c(2.5, 7.5), nrow = 1)) + expect_equal(quantile(distn, c(.1, .9)), matrix(c(1, 9), nrow = 1)) qv <- data.frame(q = l, v = v) expect_equal( - unlist(quantile(distn, c(.01, .05))), + drop(quantile(distn, c(.01, .05))), tail_extrapolate(c(.01, .05), head(qv, 2)) ) expect_equal( - unlist(quantile(distn, c(.99, .95))), + drop(quantile(distn, c(.99, .95))), tail_extrapolate(c(.95, .99), tail(qv, 2)) ) }) test_that("unary math works on quantiles", { - dstn <- dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) - dstn2 <- dist_quantiles(list(log(1:4), log(8:11)), list(c(.2, .4, .6, .8))) + dstn <- hardhat::quantile_pred( + matrix(c(1:4, 8:11), nrow = 2, byrow = TRUE), + 1:4 / 5 + ) + dstn2 <- hardhat::quantile_pred( + log(matrix(c(1:4, 8:11), nrow = 2, byrow = TRUE)), + 1:4 / 5 + ) expect_identical(log(dstn), dstn2) - dstn2 <- dist_quantiles(list(cumsum(1:4), cumsum(8:11)), list(c(.2, .4, .6, .8))) - expect_identical(cumsum(dstn), dstn2) }) test_that("arithmetic works on quantiles", { - dstn <- dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) - dstn2 <- dist_quantiles(list(1:4 + 1, 8:11 + 1), list(c(.2, .4, .6, .8))) + dstn <- hardhat::quantile_pred( + matrix(c(1:4, 8:11), nrow = 2, byrow = TRUE), + 1:4 / 5 + ) + dstn2 <- hardhat::quantile_pred( + matrix(c(1:4, 8:11), nrow = 2, byrow = TRUE) + 1, + 1:4 / 5 + ) expect_identical(dstn + 1, dstn2) expect_identical(1 + dstn, dstn2) - dstn2 <- dist_quantiles(list(1:4 / 4, 8:11 / 4), list(c(.2, .4, .6, .8))) + dstn2 <- hardhat::quantile_pred( + matrix(c(1:4, 8:11), nrow = 2, byrow = TRUE) / 4, + 1:4 / 5 + ) expect_identical(dstn / 4, dstn2) expect_identical((1 / 4) * dstn, dstn2) expect_error(sum(dstn)) - expect_error(suppressWarnings(dstn + distributional::dist_normal())) }) From 44da76dc0c5c62d5c9d8a00a0eb9c4f561a86b82 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 09:05:13 -0700 Subject: [PATCH 29/37] pass tests --- tests/testthat/_snaps/dist_quantiles.md | 8 ++++++++ .../{test-dist_quantiles.R => test-quantile_pred.R} | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/_snaps/dist_quantiles.md rename tests/testthat/{test-dist_quantiles.R => test-quantile_pred.R} (96%) diff --git a/tests/testthat/_snaps/dist_quantiles.md b/tests/testthat/_snaps/dist_quantiles.md new file mode 100644 index 000000000..dd13dcb86 --- /dev/null +++ b/tests/testthat/_snaps/dist_quantiles.md @@ -0,0 +1,8 @@ +# arithmetic works on quantiles + + Code + sum(dstn) + Condition + Error in `vec_math()`: + ! `sum()` is not a supported operation for . + diff --git a/tests/testthat/test-dist_quantiles.R b/tests/testthat/test-quantile_pred.R similarity index 96% rename from tests/testthat/test-dist_quantiles.R rename to tests/testthat/test-quantile_pred.R index 18fe92ed2..d7c7cc4cb 100644 --- a/tests/testthat/test-dist_quantiles.R +++ b/tests/testthat/test-quantile_pred.R @@ -12,7 +12,7 @@ test_that("single quantile_pred works, quantiles are accessible", { ) Q <- stats::splinefun(c(.2, .4, .5, .6, .8), 1:5, method = "hyman") - expect_equal(quantile(z, c(.3, .7)), Q(c(.3, .7))) + expect_equal(quantile(z, c(.3, .7)), matrix(Q(c(.3, .7)), nrow = 1)) expect_identical( extrapolate_quantiles(z, c(.3, .7), middle = "linear"), hardhat::quantile_pred(matrix(c(1, 1.5, 2, 3, 4, 4.5, 5), nrow = 1), 2:8 / 10) @@ -101,5 +101,5 @@ test_that("arithmetic works on quantiles", { expect_identical(dstn / 4, dstn2) expect_identical((1 / 4) * dstn, dstn2) - expect_error(sum(dstn)) + expect_snapshot(error = TRUE, sum(dstn)) }) From faa94402e8147dcf1a57b3c080e2b437c262237c Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 11:51:58 -0700 Subject: [PATCH 30/37] woodshedding wis --- NAMESPACE | 4 +- R/weighted_interval_score.R | 100 +++++++++++++-------------------- man/weighted_interval_score.Rd | 15 +---- 3 files changed, 42 insertions(+), 77 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8e071fa8a..5caeb1f86 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -116,9 +116,7 @@ S3method(vec_arith.numeric,quantile_pred) S3method(vec_arith.quantile_pred,numeric) S3method(vec_math,quantile_pred) S3method(weighted_interval_score,default) -S3method(weighted_interval_score,dist_default) -S3method(weighted_interval_score,dist_quantiles) -S3method(weighted_interval_score,distribution) +S3method(weighted_interval_score,quantile_pred) export("%>%") export(Add_model) export(Remove_model) diff --git a/R/weighted_interval_score.R b/R/weighted_interval_score.R index cd67bbee9..4819e1d3a 100644 --- a/R/weighted_interval_score.R +++ b/R/weighted_interval_score.R @@ -13,6 +13,16 @@ #' @param actual double. Actual value(s) #' @param quantile_levels probabilities. If specified, the score will be #' computed at this set of levels. +#' @param na_handling character. Determines how `quantile_levels` without a +#' corresponding `value` are handled. For `"impute"`, missing values will be +#' calculated if possible using the available quantiles. For `"drop"`, +#' explicitly missing values are ignored in the calculation of the score, but +#' implicitly missing values are imputed if possible. +#' For `"propogate"`, the resulting score will be `NA` if any missing values +#' exist in the original `quantile_levels`. Finally, if +#' `quantile_levels` is specified, `"fail"` will result in +#' the score being `NA` when any required quantile levels (implicit or explicit) +#' are do not have corresponding values. #' @param ... not used #' #' @return a vector of nonnegative scores. @@ -58,90 +68,56 @@ #' ) %>% #' mutate(wis = weighted_interval_score(.pred_distn, actual)) #' preds -weighted_interval_score <- function(x, actual, quantile_levels = NULL, ...) { +weighted_interval_score <- function( + x, + actual, + quantile_levels = NULL, + na_handling = c("impute", "drop", "propagate", "fail"), + ...) { UseMethod("weighted_interval_score") } #' @export -weighted_interval_score.default <- function(x, actual, - quantile_levels = NULL, ...) { - cli_abort(c( +weighted_interval_score.default <- function( + x, actual, + quantile_levels = NULL, + na_handling = c("impute", "drop", "propagate", "fail"), + ...) { + cli_abort(paste( "Weighted interval score can only be calculated if `x`", - "has class {.cls distribution}." + "has class {.cls quantile_pred}." )) } #' @export -weighted_interval_score.distribution <- function( - x, actual, - quantile_levels = NULL, ...) { - assert_numeric(actual, finite = TRUE) - l <- vctrs::vec_recycle_common(x = x, actual = actual) - map2_dbl( - .x = vctrs::vec_data(l$x), - .y = l$actual, - .f = weighted_interval_score, - quantile_levels = quantile_levels, - ... - ) -} - -#' @export -weighted_interval_score.dist_default <- function(x, actual, - quantile_levels = NULL, ...) { - rlang::check_dots_empty() - if (is.null(quantile_levels)) { - cli_warn(c( - "Weighted interval score isn't implemented for {.cls {class(x)}}", - "as we don't know what set of quantile levels to use.", - "Use a {.cls dist_quantiles} or pass `quantile_levels`.", - "The result for this element will be `NA`." - )) - return(NA) - } - x <- extrapolate_quantiles(x, probs = quantile_levels) - weighted_interval_score(x, actual, quantile_levels = NULL) -} - -#' @param na_handling character. Determines how `quantile_levels` without a -#' corresponding `value` are handled. For `"impute"`, missing values will be -#' calculated if possible using the available quantiles. For `"drop"`, -#' explicitly missing values are ignored in the calculation of the score, but -#' implicitly missing values are imputed if possible. -#' For `"propogate"`, the resulting score will be `NA` if any missing values -#' exist in the original `quantile_levels`. Finally, if -#' `quantile_levels` is specified, `"fail"` will result in -#' the score being `NA` when any required quantile levels (implicit or explicit) -#' are do not have corresponding values. -#' @describeIn weighted_interval_score Weighted interval score with -#' `dist_quantiles` allows for different `NA` behaviours. -#' @export -weighted_interval_score.dist_quantiles <- function( +weighted_interval_score.quantile_pred <- function( x, actual, quantile_levels = NULL, na_handling = c("impute", "drop", "propagate", "fail"), ...) { rlang::check_dots_empty() - if (is.na(actual)) { - return(NA) - } - if (all(is.na(vctrs::field(x, "values")))) { - return(NA) - } + n <- vctrs::vec_size(x) + if (length(actual) == 1L) actual <- rep(actual, n) + assert_numeric(actual, finite = TRUE, len = n) + assert_numeric(quantile_levels, lower = 0, upper = 1, null.ok = TRUE) na_handling <- rlang::arg_match(na_handling) - old_quantile_levels <- field(x, "quantile_levels") + old_quantile_levels <- x %@% "quantile_levels" if (na_handling == "fail") { if (is.null(quantile_levels)) { cli_abort('`na_handling = "fail"` requires `quantile_levels` to be specified.') } - old_values <- field(x, "values") - if (!all(quantile_levels %in% old_quantile_levels) || any(is.na(old_values))) { - return(NA) + if (!all(quantile_levels %in% old_quantile_levels)) { + return(rep(NA_real_, n)) } } tau <- quantile_levels %||% old_quantile_levels - x <- extrapolate_quantiles(x, probs = tau, replace_na = (na_handling == "impute")) - q <- field(x, "values")[field(x, "quantile_levels") %in% tau] + x <- extrapolate_quantiles(x, tau, replace_na = (na_handling == "impute")) + x <- as.matrix(x)[, attr(x, "quantile_levels") %in% tau] na_rm <- (na_handling == "drop") + map2_dbl(vctrs::vec_chop(x), actual, ~ wis_one_quantile(.x, tau, .y, na_rm)) +} + +wis_one_quantile <- function(q, tau, actual, na_rm) { 2 * mean(pmax(tau * (actual - q), (1 - tau) * (q - actual)), na.rm = na_rm) } + diff --git a/man/weighted_interval_score.Rd b/man/weighted_interval_score.Rd index 4907e2724..4b7c796ea 100644 --- a/man/weighted_interval_score.Rd +++ b/man/weighted_interval_score.Rd @@ -2,12 +2,9 @@ % Please edit documentation in R/weighted_interval_score.R \name{weighted_interval_score} \alias{weighted_interval_score} -\alias{weighted_interval_score.dist_quantiles} \title{Compute weighted interval score} \usage{ -weighted_interval_score(x, actual, quantile_levels = NULL, ...) - -\method{weighted_interval_score}{dist_quantiles}( +weighted_interval_score( x, actual, quantile_levels = NULL, @@ -25,8 +22,6 @@ contains \code{dist_quantiles()}, though other distributions are supported when \item{quantile_levels}{probabilities. If specified, the score will be computed at this set of levels.} -\item{...}{not used} - \item{na_handling}{character. Determines how \code{quantile_levels} without a corresponding \code{value} are handled. For \code{"impute"}, missing values will be calculated if possible using the available quantiles. For \code{"drop"}, @@ -37,6 +32,8 @@ exist in the original \code{quantile_levels}. Finally, if \code{quantile_levels} is specified, \code{"fail"} will result in the score being \code{NA} when any required quantile levels (implicit or explicit) are do not have corresponding values.} + +\item{...}{not used} } \value{ a vector of nonnegative scores. @@ -48,12 +45,6 @@ approximation of the commonly-used continuous ranked probability score generalization of absolute error. For example, see \href{https://arxiv.org/abs/2005.12881}{Bracher et al. (2020)} for discussion in the context of COVID-19 forecasting. } -\section{Methods (by class)}{ -\itemize{ -\item \code{weighted_interval_score(dist_quantiles)}: Weighted interval score with -\code{dist_quantiles} allows for different \code{NA} behaviours. - -}} \examples{ quantile_levels <- c(.2, .4, .6, .8) predq_1 <- 1:4 # From 2646b0ea90beb7f2d63e13c0e17008c1859afe9a Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 11:56:05 -0700 Subject: [PATCH 31/37] pass local tests --- tests/testthat/_snaps/dist_quantiles.md | 2 +- tests/testthat/test-dist_quantiles.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/_snaps/dist_quantiles.md b/tests/testthat/_snaps/dist_quantiles.md index da7e50100..1d626e089 100644 --- a/tests/testthat/_snaps/dist_quantiles.md +++ b/tests/testthat/_snaps/dist_quantiles.md @@ -1,7 +1,7 @@ # constructor returns reasonable quantiles Code - new_quantiles(rnorm(5), rnorm(5)) + new_quantiles(rnorm(5), c(-2, -1, 0, 1, 2)) Condition Error in `new_quantiles()`: ! `quantile_levels` must lie in [0, 1]. diff --git a/tests/testthat/test-dist_quantiles.R b/tests/testthat/test-dist_quantiles.R index 8112326dc..66f229956 100644 --- a/tests/testthat/test-dist_quantiles.R +++ b/tests/testthat/test-dist_quantiles.R @@ -1,7 +1,7 @@ library(distributional) test_that("constructor returns reasonable quantiles", { - expect_snapshot(error = TRUE, new_quantiles(rnorm(5), rnorm(5))) + expect_snapshot(error = TRUE, new_quantiles(rnorm(5), c(-2, -1, 0, 1, 2))) expect_silent(new_quantiles(sort(rnorm(5)), sort(runif(5)))) expect_snapshot(error = TRUE, new_quantiles(sort(rnorm(5)), sort(runif(2)))) expect_silent(new_quantiles(1:5, 1:5 / 10)) From b4fa6e6a97040baa843e380e78eead757343ba40 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 12:20:05 -0700 Subject: [PATCH 32/37] strange unpassable snapshot test --- tests/testthat/_snaps/layer_predict.md | 8 -------- tests/testthat/test-layer_predict.R | 2 +- 2 files changed, 1 insertion(+), 9 deletions(-) delete mode 100644 tests/testthat/_snaps/layer_predict.md diff --git a/tests/testthat/_snaps/layer_predict.md b/tests/testthat/_snaps/layer_predict.md deleted file mode 100644 index 5c353eb4c..000000000 --- a/tests/testthat/_snaps/layer_predict.md +++ /dev/null @@ -1,8 +0,0 @@ -# layer_predict dots validation - - Code - predict(wf_bad_arg, latest) - Condition - Error: - ! argument "..3" is missing, with no default - diff --git a/tests/testthat/test-layer_predict.R b/tests/testthat/test-layer_predict.R index 70e76e593..041516b29 100644 --- a/tests/testthat/test-layer_predict.R +++ b/tests/testthat/test-layer_predict.R @@ -48,7 +48,7 @@ test_that("layer_predict dots validation", { # We don't detect completely-bogus arg names until predict time: expect_no_error(f_bad_arg <- frosting() %>% layer_predict(bogus_argument = "something")) wf_bad_arg <- wf %>% add_frosting(f_bad_arg) - expect_snapshot(error = TRUE, predict(wf_bad_arg, latest)) + expect_error(predict(wf_bad_arg, latest)) # ^ (currently with a awful error message, due to an extra comma in parsnip::check_pred_type_dots) # Some argument names only apply for some prediction `type`s; we don't check From be4fd5d34e9fa987bdee997bba2b68516abf2ac8 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 12:39:25 -0700 Subject: [PATCH 33/37] remove old snap --- tests/testthat/_snaps/dist_quantiles.md | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 tests/testthat/_snaps/dist_quantiles.md diff --git a/tests/testthat/_snaps/dist_quantiles.md b/tests/testthat/_snaps/dist_quantiles.md deleted file mode 100644 index dd13dcb86..000000000 --- a/tests/testthat/_snaps/dist_quantiles.md +++ /dev/null @@ -1,8 +0,0 @@ -# arithmetic works on quantiles - - Code - sum(dstn) - Condition - Error in `vec_math()`: - ! `sum()` is not a supported operation for . - From 0167700775421ce4fd0a2ceb7ecb8bf9d76e41a6 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 16:13:25 -0700 Subject: [PATCH 34/37] excise dist_quantiles and nested_quantiles --- NAMESPACE | 6 +- R/autoplot.R | 2 +- R/extrapolate_quantiles.R | 32 ++-- R/flusight_hub_formatter.R | 11 +- R/layer_cdc_flatline_quantiles.R | 7 +- R/layer_predictive_distn.R | 6 + R/layer_quantile_distn.R | 13 +- R/layer_residual_quantiles.R | 20 +-- R/layer_threshold_preds.R | 23 +-- R/make_grf_quantiles.R | 4 +- R/make_quantile_reg.R | 22 +-- R/make_smooth_quantile_reg.R | 7 +- R/pivot_quantiles.R | 158 +++++------------- R/quantile_pred-methods.R | 14 +- R/weighted_interval_score.R | 34 ++-- man/extrapolate_quantiles.Rd | 32 ++-- man/flusight_hub_formatter.Rd | 4 +- man/layer_cdc_flatline_quantiles.Rd | 2 +- man/nested_quantiles.Rd | 26 --- man/pivot_quantiles_longer.Rd | 25 +-- man/pivot_quantiles_wider.Rd | 19 ++- man/smooth_quantile_reg.Rd | 5 +- man/weighted_interval_score.Rd | 32 ++-- tests/testthat/_snaps/pivot_quantiles.md | 40 +++++ tests/testthat/_snaps/quantile_pred.md | 8 + tests/testthat/_snaps/wis-quantile_pred.md | 16 ++ .../testthat/test-layer_residual_quantiles.R | 5 +- tests/testthat/test-layer_threshold_preds.R | 7 +- tests/testthat/test-pivot_quantiles.R | 76 +++------ ...t-quantiles.R => test-wis-quantile_pred.R} | 31 ++-- 30 files changed, 293 insertions(+), 394 deletions(-) delete mode 100644 man/nested_quantiles.Rd create mode 100644 tests/testthat/_snaps/pivot_quantiles.md create mode 100644 tests/testthat/_snaps/quantile_pred.md create mode 100644 tests/testthat/_snaps/wis-quantile_pred.md rename tests/testthat/{test-wis-dist-quantiles.R => test-wis-quantile_pred.R} (60%) diff --git a/NAMESPACE b/NAMESPACE index 5caeb1f86..fae784a90 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -104,9 +104,7 @@ S3method(slather,layer_residual_quantiles) S3method(slather,layer_threshold) S3method(slather,layer_unnest) S3method(snap,default) -S3method(snap,dist_default) -S3method(snap,dist_quantiles) -S3method(snap,distribution) +S3method(snap,quantile_pred) S3method(tidy,check_enough_train_data) S3method(tidy,frosting) S3method(tidy,layer) @@ -172,7 +170,6 @@ export(layer_quantile_distn) export(layer_residual_quantiles) export(layer_threshold) export(layer_unnest) -export(nested_quantiles) export(pivot_quantiles_longer) export(pivot_quantiles_wider) export(prep) @@ -246,6 +243,7 @@ importFrom(ggplot2,geom_line) importFrom(ggplot2,geom_linerange) importFrom(ggplot2,geom_point) importFrom(ggplot2,geom_ribbon) +importFrom(hardhat,quantile_pred) importFrom(hardhat,refresh_blueprint) importFrom(hardhat,run_mold) importFrom(magrittr,"%>%") diff --git a/R/autoplot.R b/R/autoplot.R index dab763fe0..dc304fb7f 100644 --- a/R/autoplot.R +++ b/R/autoplot.R @@ -248,7 +248,7 @@ plot_bands <- function( ntarget_dates <- dplyr::n_distinct(predictions$time_value) predictions <- predictions %>% - mutate(.pred_distn = dist_quantiles(quantile(.pred_distn, l), l)) %>% + mutate(.pred_distn = quantile_pred(quantile(.pred_distn, l), l)) %>% pivot_quantiles_wider(.pred_distn) qnames <- setdiff(names(predictions), innames) diff --git a/R/extrapolate_quantiles.R b/R/extrapolate_quantiles.R index d9e899ef6..82116c1d3 100644 --- a/R/extrapolate_quantiles.R +++ b/R/extrapolate_quantiles.R @@ -1,32 +1,26 @@ #' Summarize a distribution with a set of quantiles #' -#' @param x a `distribution` vector +#' This function takes a `quantile_pred` vector and returns the same +#' type of object, expanded to include +#' *additional* quantiles computed at `probs`. If you want behaviour more +#' similar to [stats::quantile()], then `quantile(x,...)` may be more +#' appropriate. +#' +#' @param x A vector of class `quantile_pred`. #' @param probs a vector of probabilities at which to calculate quantiles #' @param replace_na logical. If `x` contains `NA`'s, these are imputed if -#' possible (if `TRUE`) or retained (if `FALSE`). This only effects -#' elements of class `dist_quantiles`. +#' possible (if `TRUE`) or retained (if `FALSE`). #' @param ... additional arguments passed on to the `quantile` method #' -#' @return a `distribution` vector containing `dist_quantiles`. Any elements -#' of `x` which were originally `dist_quantiles` will now have a superset +#' @return a `quantile_pred` vector. Each element +#' of `x` will now have a superset #' of the original `quantile_values` (the union of those and `probs`). #' @export #' #' @examples -#' library(distributional) -#' dstn <- dist_normal(c(10, 2), c(5, 10)) -#' extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) -#' -#' dstn <- dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) -#' # because this distribution is already quantiles, any extra quantiles are -#' # appended -#' extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) -#' -#' dstn <- c( -#' dist_normal(c(10, 2), c(5, 10)), -#' dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) -#' ) -#' extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) +#' dstn <- quantile_dstn(rbind(1:4, 8:11), c(.2, .4, .6, .8)) +#' # extra quantiles are appended +#' as.tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))) extrapolate_quantiles <- function(x, probs, replace_na = TRUE, ...) { UseMethod("extrapolate_quantiles") } diff --git a/R/flusight_hub_formatter.R b/R/flusight_hub_formatter.R index c91f738ae..55f19f5c3 100644 --- a/R/flusight_hub_formatter.R +++ b/R/flusight_hub_formatter.R @@ -67,11 +67,11 @@ abbr_to_location <- function(abbr) { #' mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) %>% #' select(-pop, -death_rate) %>% #' group_by(geo_value) %>% -#' epi_slide(~ sum(.$deaths), before = 6, new_col_name = "deaths") %>% +#' epi_slide(~ sum(.$deaths), .window_size = 7, .new_col_name = "deaths_sum") %>% #' ungroup() %>% #' filter(weekdays(time_value) == "Saturday") #' -#' cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths") +#' cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths_sum") #' flusight_hub_formatter(cdc) #' flusight_hub_formatter(cdc, target = "wk inc covid deaths") #' flusight_hub_formatter(cdc, target = paste(horizon, "wk inc covid deaths")) @@ -105,12 +105,11 @@ flusight_hub_formatter.data.frame <- function( object <- object %>% # combine the predictions and the distribution - mutate(.pred_distn = nested_quantiles(.pred_distn)) %>% - tidyr::unnest(.pred_distn) %>% + pivot_quantiles_longer(.pred_distn) %>% # now we create the correct column names rename( - value = values, - output_type_id = quantile_levels, + value = .pred_distn_value, + output_type_id = .pred_distn_quantile_level, reference_date = forecast_date ) %>% # convert to fips codes, and add any constant cols passed in ... diff --git a/R/layer_cdc_flatline_quantiles.R b/R/layer_cdc_flatline_quantiles.R index 926198e11..1c60536fc 100644 --- a/R/layer_cdc_flatline_quantiles.R +++ b/R/layer_cdc_flatline_quantiles.R @@ -51,7 +51,7 @@ #' in an additional `` named `.pred_distn_all` containing 2-column #' [tibble::tibble()]'s. For each #' desired combination of `key`'s, the tibble will contain one row per ahead -#' with the associated [dist_quantiles()]. +#' with the associated [quantile_pred()]. #' @export #' #' @examples @@ -266,11 +266,10 @@ propagate_samples <- function( } } res <- res[aheads] + res_quantiles <- map(res, quantile, probs = quantile_levels) list(tibble( ahead = aheads, - .pred_distn = map_vec( - res, ~ dist_quantiles(quantile(.x, quantile_levels), quantile_levels) - ) + .pred_distn = quantile_pred(do.call(rbind, res_quantiles), quantile_levels) )) } diff --git a/R/layer_predictive_distn.R b/R/layer_predictive_distn.R index 6cbb58cfb..e6cf6ef52 100644 --- a/R/layer_predictive_distn.R +++ b/R/layer_predictive_distn.R @@ -45,6 +45,12 @@ layer_predictive_distn <- function(frosting, truncate = c(-Inf, Inf), name = ".pred_distn", id = rand_id("predictive_distn")) { + if (!requireNamespace("distributional", quietly = TRUE)) { + cli_abort(paste( + "You must install the {.pkg distributional} package for", + "this functionality." + )) + } rlang::check_dots_empty() arg_is_chr_scalar(name, id) dist_type <- match.arg(dist_type) diff --git a/R/layer_quantile_distn.R b/R/layer_quantile_distn.R index d1c3a9d24..7fa1942c4 100644 --- a/R/layer_quantile_distn.R +++ b/R/layer_quantile_distn.R @@ -79,15 +79,22 @@ layer_quantile_distn_new <- function(quantile_levels, truncate, name, id) { slather.layer_quantile_distn <- function(object, components, workflow, new_data, ...) { dstn <- components$predictions$.pred - if (!inherits(dstn, "distribution")) { + is_supported <- inherits(dstn, "distribution") || inherits(dstn, "quantile_pred") + if (!is_supported) { cli_abort(c( - "`layer_quantile_distn()` requires distributional predictions.", + "`layer_quantile_distn()` requires distributional or quantile predictions.", "These are of class {.cls {class(dstn)}}." )) } + if (inherits(dstn, "distribution") && !requireNamespace("distributional", quietly = TRUE)) { + cli_abort(paste( + "You must install the {.pkg distributional} package for", + "this functionality." + )) + } rlang::check_dots_empty() - dstn <- dist_quantiles( + dstn <- quantile_pred( quantile(dstn, object$quantile_levels), object$quantile_levels ) diff --git a/R/layer_residual_quantiles.R b/R/layer_residual_quantiles.R index 2e08494f2..69d49e4fa 100644 --- a/R/layer_residual_quantiles.R +++ b/R/layer_residual_quantiles.R @@ -123,15 +123,17 @@ slather.layer_residual_quantiles <- } } - r <- r %>% - summarize( - dstn = list(quantile( - c(.resid, s * .resid), - probs = object$quantile_levels, na.rm = TRUE - )) + r <- summarize( + r, + dstn = quantile_pred( + matrix(quantile( + c(.resid, s * .resid), probs = object$quantile_levels, na.rm = TRUE + ), nrow = 1), + quantile_levels = object$quantile_levels ) + ) # Check for NA - if (any(sapply(r$dstn, is.na))) { + if (any(is.na(as.matrix(r$dstn)))) { cli::cli_abort(c( "Residual quantiles could not be calculated due to missing residuals.", i = "This may be due to `n_train` < `ahead` in your {.cls epi_recipe}." @@ -139,9 +141,7 @@ slather.layer_residual_quantiles <- } estimate <- components$predictions$.pred - res <- tibble( - .pred_distn = dist_quantiles(map2(estimate, r$dstn, "+"), object$quantile_levels) - ) + res <- tibble(.pred_distn = r$dstn + estimate) res <- check_pname(res, components$predictions, object) components$predictions <- mutate(components$predictions, !!!res) components diff --git a/R/layer_threshold_preds.R b/R/layer_threshold_preds.R index da397fb18..f29db3b93 100644 --- a/R/layer_threshold_preds.R +++ b/R/layer_threshold_preds.R @@ -72,26 +72,13 @@ snap.default <- function(x, lower, upper, ...) { pmin(pmax(x, lower), upper) } -#' @export -snap.distribution <- function(x, lower, upper, ...) { - rlang::check_dots_empty() - arg_is_scalar(lower, upper) - dstn <- lapply(vec_data(x), snap, lower = lower, upper = upper) - distributional:::wrap_dist(dstn) -} - -#' @export -snap.dist_default <- function(x, lower, upper, ...) { - rlang::check_dots_empty() - x -} #' @export -snap.dist_quantiles <- function(x, lower, upper, ...) { - values <- field(x, "values") - quantile_levels <- field(x, "quantile_levels") - values <- snap(values, lower, upper) - new_quantiles(values = values, quantile_levels = quantile_levels) +snap.quantile_pred <- function(x, lower, upper, ...) { + values <- as.matrix(x) + quantile_levels <- x %@% "quantile_levels" + values <- map(vctrs::vec_chop(values), ~ snap(.x, lower, upper)) + quantile_pred(do.call(rbind, values), quantile_levels = quantile_levels) } #' @export diff --git a/R/make_grf_quantiles.R b/R/make_grf_quantiles.R index 253ea1ac7..da3383566 100644 --- a/R/make_grf_quantiles.R +++ b/R/make_grf_quantiles.R @@ -163,12 +163,12 @@ make_grf_quantiles <- function() { ) ) - # turn the predictions into a tibble with a dist_quantiles column + # turn the predictions into a tibble with a quantile_pred column process_qrf_preds <- function(x, object) { quantile_levels <- parsnip::extract_fit_engine(object)$quantiles.orig x <- x$predictions out <- lapply(vctrs::vec_chop(x), function(x) sort(drop(x))) - out <- dist_quantiles(out, list(quantile_levels)) + out <- hardhat::quantile_pred(do.call(rbind, out), quantile_levels) return(dplyr::tibble(.pred = out)) } diff --git a/R/make_quantile_reg.R b/R/make_quantile_reg.R index 2157aa470..305a81941 100644 --- a/R/make_quantile_reg.R +++ b/R/make_quantile_reg.R @@ -108,21 +108,13 @@ make_quantile_reg <- function() { process_rq_preds <- function(x, object) { object <- parsnip::extract_fit_engine(object) - type <- class(object)[1] - - # can't make a method because object is second - out <- switch(type, - rq = dist_quantiles(unname(as.list(x)), object$quantile_levels), # one quantile - rqs = { - x <- lapply(vctrs::vec_chop(x), function(x) sort(drop(x))) - dist_quantiles(x, list(object$tau)) - }, - cli_abort(c( - "Prediction is not implemented for this `rq` type.", - i = "See {.fun quantreg::rq}." - )) - ) - return(dplyr::tibble(.pred = out)) + if (!is.matrix(x)) { + x <- as.matrix(x) + } + rownames(x) <- NULL + n_pred_quantiles <- ncol(x) + quantile_levels <- object$tau + tibble(.pred = hardhat::quantile_pred(x, quantile_levels)) } parsnip::set_pred( diff --git a/R/make_smooth_quantile_reg.R b/R/make_smooth_quantile_reg.R index 448ee0fa5..72294140a 100644 --- a/R/make_smooth_quantile_reg.R +++ b/R/make_smooth_quantile_reg.R @@ -48,13 +48,12 @@ #' ) #' pl <- pl %>% #' unnest(.pred) %>% -#' mutate(distn = nested_quantiles(distn)) %>% -#' unnest(distn) %>% +#' pivot_quantiles_longer(distn) %>% #' mutate( #' x = x[length(x) - 20] + ahead / 100 * 2 * pi, #' ahead = NULL #' ) %>% -#' pivot_wider(names_from = quantile_levels, values_from = values) +#' pivot_wider(names_from = distn_quantile_level, values_from = distn_value) #' plot(x, y, pch = 16, xlim = c(pi, 2 * pi), col = "lightgrey") #' curve(sin(x), add = TRUE) #' abline(v = fd, lty = 2) @@ -178,7 +177,7 @@ make_smooth_quantile_reg <- function() { x <- lapply(unname(split( p, seq(nrow(p)) )), function(q) unname(sort(q, na.last = TRUE))) - dist_quantiles(x, list(object$tau)) + quantile_pred(do.call(rbind, x), object$tau) }) n_preds <- length(list_of_pred_distns[[1]]) nout <- length(list_of_pred_distns) diff --git a/R/pivot_quantiles.R b/R/pivot_quantiles.R index c8601b4f6..8f914f5b8 100644 --- a/R/pivot_quantiles.R +++ b/R/pivot_quantiles.R @@ -1,148 +1,75 @@ -#' Turn a vector of quantile distributions into a list-col +#' Pivot a column containing `quantile_pred` longer #' -#' @param x a `distribution` containing `dist_quantiles` -#' -#' @return a list-col -#' @export -#' -#' @examples -#' library(dplyr) -#' library(tidyr) -#' edf <- case_death_rate_subset[1:3, ] -#' edf$q <- dist_quantiles(list(1:5, 2:4, 3:10), list(1:5 / 6, 2:4 / 5, 3:10 / 11)) -#' -#' edf_nested <- edf %>% mutate(q = nested_quantiles(q)) -#' edf_nested %>% unnest(q) -nested_quantiles <- function(x) { - stopifnot(is_dist_quantiles(x)) - distributional:::dist_apply(x, .f = function(z) { - as_tibble(vec_data(z)) %>% - mutate(across(everything(), as.double)) %>% - vctrs::list_of() - }) -} - - -#' Pivot columns containing `dist_quantile` longer -#' -#' Selected columns that contain `dist_quantiles` will be "lengthened" with +#' A column that contains `quantile_pred` will be "lengthened" with #' the quantile levels serving as 1 column and the values as another. If #' multiple columns are selected, these will be prefixed with the column name. #' #' @param .data A data frame, or a data frame extension such as a tibble or #' epi_df. -#' @param ... <[`tidy-select`][dplyr::dplyr_tidy_select]> One or more unquoted +#' @param ... <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted #' expressions separated by commas. Variable names can be used as if they #' were positions in the data frame, so expressions like `x:y` can -#' be used to select a range of variables. -#' @param .ignore_length_check If multiple columns are selected, as long as -#' each row has contains the same number of quantiles, the result will be -#' reasonable. But if, for example, `var1[1]` has 5 quantiles while `var2[1]` -#' has 7, then the only option would be to recycle everything, creating a -#' _very_ long result. By default, this would throw an error. But if this is -#' really the goal, then the error can be bypassed by setting this argument -#' to `TRUE`. The quantiles in the first selected column will vary the fastest. +#' be used to select a range of variables. Note that only one variable +#' can be selected for this operation #' #' @return An object of the same class as `.data`. #' @export #' #' @examples -#' d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 1:3 / 4)) -#' d2 <- c(dist_quantiles(2:4, 2:4 / 5), dist_quantiles(3:5, 2:4 / 5)) +#' d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4) +#' d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5) #' tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2) #' #' pivot_quantiles_longer(tib, "d1") #' pivot_quantiles_longer(tib, dplyr::ends_with("1")) -#' pivot_quantiles_longer(tib, d1, d2) -pivot_quantiles_longer <- function(.data, ..., .ignore_length_check = FALSE) { - cols <- validate_pivot_quantiles(.data, ...) - .data <- .data %>% mutate(across(all_of(cols), nested_quantiles)) - if (length(cols) > 1L) { - lengths_check <- .data %>% - dplyr::transmute(across(all_of(cols), ~ map_int(.x, vctrs::vec_size))) %>% - as.matrix() %>% - apply(1, function(x) dplyr::n_distinct(x) == 1L) %>% - all() - if (lengths_check) { - .data <- tidyr::unnest(.data, all_of(cols), names_sep = "_") - } else { - if (.ignore_length_check) { - for (col in cols) { - .data <- .data %>% tidyr::unnest(all_of(col), names_sep = "_") - } - } else { - cli::cli_abort(c( - "Some selected columns contain different numbers of quantiles.", - "The result would be a {.emph very} long {.cls tibble}.", - "To do this anyway, rerun with `.ignore_length_check = TRUE`." - )) - } - } - } else { - .data <- .data %>% tidyr::unnest(all_of(cols)) - } - .data +#' pivot_quantiles_longer(tib, d2) +pivot_quantiles_longer <- function(.data, ...) { + col <- validate_pivot_quantiles(.data, ...) + .data$.row <- seq_len(vctrs::vec_size(.data)) + long_tib <- as_tibble(.data[[col]]) + .data <- select(.data, !all_of(col)) + names(long_tib)[1:2] <- c(glue::glue("{col}_value"), glue::glue("{col}_quantile_level")) + left_join(.data, long_tib, by = ".row") %>% + select(!.row) } -#' Pivot columns containing `dist_quantile` wider +#' Pivot a column containing `quantile_pred` wider #' -#' Any selected columns that contain `dist_quantiles` will be "widened" with +#' Any selected columns that contain `quantile_pred` will be "widened" with #' the "taus" (quantile) serving as names and the values in the data frame. #' When pivoting multiple columns, the original column name will be used as #' a prefix. #' #' @param .data A data frame, or a data frame extension such as a tibble or #' epi_df. -#' @param ... <[`tidy-select`][dplyr::dplyr_tidy_select]> One or more unquoted +#' @param ... <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted #' expressions separated by commas. Variable names can be used as if they #' were positions in the data frame, so expressions like `x:y` can -#' be used to select a range of variables. +#' be used to select a range of variables. Note that only one variable +#' can be selected for this operation #' #' @return An object of the same class as `.data` #' @export #' #' @examples -#' d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 1:3 / 4)) -#' d2 <- c(dist_quantiles(2:4, 2:4 / 5), dist_quantiles(3:5, 2:4 / 5)) -#' tib <- tibble::tibble(g = c("a", "b"), d1 = d1, d2 = d2) +#' d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4) +#' d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5) +#' tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2) #' -#' pivot_quantiles_wider(tib, c("d1", "d2")) -#' pivot_quantiles_wider(tib, dplyr::starts_with("d")) +#' pivot_quantiles_wider(tib, "d1") +#' pivot_quantiles_wider(tib, dplyr::ends_with("2")) #' pivot_quantiles_wider(tib, d2) pivot_quantiles_wider <- function(.data, ...) { - cols <- validate_pivot_quantiles(.data, ...) - .data <- .data %>% mutate(across(all_of(cols), nested_quantiles)) - checks <- map_lgl(cols, ~ diff(range(vctrs::list_sizes(.data[[.x]]))) == 0L) - if (!all(checks)) { - nms <- cols[!checks] - cli::cli_abort(c( - "Quantiles must be the same length and have the same set of taus.", - i = "Check failed for variables(s) {.var {nms}}." - )) - } - - # tidyr::pivot_wider can crash if there are duplicates, this generally won't - # happen in our context. To avoid, silently add an index column and remove it - # later - .hidden_index <- seq_len(nrow(.data)) - .data <- tibble::add_column(.data, .hidden_index = .hidden_index) - if (length(cols) > 1L) { - for (col in cols) { - .data <- .data %>% - tidyr::unnest(all_of(col)) %>% - tidyr::pivot_wider( - names_from = "quantile_levels", values_from = "values", - names_prefix = paste0(col, "_") - ) - } - } else { - .data <- .data %>% - tidyr::unnest(all_of(cols)) %>% - tidyr::pivot_wider(names_from = "quantile_levels", values_from = "values") - } - select(.data, -.hidden_index) + col <- validate_pivot_quantiles(.data, ...) + .data$.row <- seq_len(vctrs::vec_size(.data)) + wide_tib <- as_tibble(.data[[col]]) %>% + tidyr::pivot_wider(names_from = .quantile_levels, values_from = .pred_quantile) + .data <- select(.data, !all_of(col)) + left_join(.data, wide_tib, by = ".row") %>% + select(!.row) } + pivot_quantiles <- function(.data, ...) { msg <- c( "{.fn pivot_quantiles} was deprecated in {.pkg epipredict} 0.0.6", @@ -151,14 +78,19 @@ pivot_quantiles <- function(.data, ...) { deprecate_stop(msg) } -validate_pivot_quantiles <- function(.data, ...) { +validate_pivot_quantiles <- function(.data, ..., call = caller_env()) { expr <- rlang::expr(c(...)) cols <- names(tidyselect::eval_select(expr, .data)) - dqs <- map_lgl(cols, ~ is_dist_quantiles(.data[[.x]])) - if (!all(dqs)) { - nms <- cols[!dqs] - cli::cli_abort( - "Variables(s) {.var {nms}} are not `dist_quantiles`. Cannot pivot them." + if (length(cols) > 1L) { + cli_abort( + "Only one column can be pivotted. Can not pivot all of: {.var {cols}}.", + call = call + ) + } + if (!inherits(.data[[cols]], "quantile_pred")) { + cli_abort( + "{.var {cols}} is not {.cls `quantile_pred`}. Cannot pivot it.", + call = call ) } cols diff --git a/R/quantile_pred-methods.R b/R/quantile_pred-methods.R index 04884ccd0..1f86052d1 100644 --- a/R/quantile_pred-methods.R +++ b/R/quantile_pred-methods.R @@ -1,5 +1,6 @@ # placeholder to avoid errors, but not ideal +#' @importFrom hardhat quantile_pred #' @export mean.quantile_pred <- function(x, na.rm = FALSE, ...) { median(x, ...) @@ -46,6 +47,7 @@ quantile_internal <- function(x, tau_out, middle) { extrapolate_quantiles_single <- function(qvals, tau, tau_out, middle) { qvals_out <- rep(NA, length(tau_out)) good <- !is.na(qvals) + if (!any(good)) return(qvals_out) qvals <- qvals[good] tau <- tau[good] @@ -131,7 +133,7 @@ vec_math.quantile_pred <- function(.fn, .x, ...) { } quantile_levels <- .x %@% "quantile_levels" .x <- as.matrix(.x) - hardhat::quantile_pred(.fn(.x), quantile_levels) + quantile_pred(.fn(.x), quantile_levels) } #' @importFrom vctrs vec_arith vec_arith.numeric @@ -145,14 +147,16 @@ vec_arith.quantile_pred <- function(op, x, y, ...) { #' @method vec_arith.quantile_pred numeric vec_arith.quantile_pred.numeric <- function(op, x, y, ...) { op_fn <- getExportedValue("base", op) - out <- op_fn(as.matrix(x), y) - hardhat::quantile_pred(out, x %@% "quantile_levels") + l <- vctrs::vec_recycle_common(x = x, y = y) + out <- op_fn(as.matrix(l$x), l$y) + quantile_pred(out, x %@% "quantile_levels") } #' @export #' @method vec_arith.numeric quantile_pred vec_arith.numeric.quantile_pred <- function(op, x, y, ...) { op_fn <- getExportedValue("base", op) - out <- op_fn(x, as.matrix(y)) - hardhat::quantile_pred(out, y %@% "quantile_levels") + l <- vctrs::vec_recycle_common(x = x, y = y) + out <- op_fn(l$x, as.matrix(l$y)) + quantile_pred(out, y %@% "quantile_levels") } diff --git a/R/weighted_interval_score.R b/R/weighted_interval_score.R index 4819e1d3a..ddeeced17 100644 --- a/R/weighted_interval_score.R +++ b/R/weighted_interval_score.R @@ -7,22 +7,21 @@ #' al. (2020)](https://arxiv.org/abs/2005.12881) for discussion in the context #' of COVID-19 forecasting. #' -#' @param x distribution. A vector of class distribution. Ideally, this vector -#' contains `dist_quantiles()`, though other distributions are supported when -#' `quantile_levels` is specified. See below. +#' @param x A vector of class `quantile_pred`. #' @param actual double. Actual value(s) #' @param quantile_levels probabilities. If specified, the score will be -#' computed at this set of levels. -#' @param na_handling character. Determines how `quantile_levels` without a -#' corresponding `value` are handled. For `"impute"`, missing values will be +#' computed at this set of levels. Otherwise, those present in `x` will be +#' used. +#' @param na_handling character. Determines missing values are handled. +#' For `"impute"`, missing values will be #' calculated if possible using the available quantiles. For `"drop"`, #' explicitly missing values are ignored in the calculation of the score, but #' implicitly missing values are imputed if possible. #' For `"propogate"`, the resulting score will be `NA` if any missing values -#' exist in the original `quantile_levels`. Finally, if +#' exist. Finally, if #' `quantile_levels` is specified, `"fail"` will result in #' the score being `NA` when any required quantile levels (implicit or explicit) -#' are do not have corresponding values. +#' do not have corresponding values. #' @param ... not used #' #' @return a vector of nonnegative scores. @@ -30,24 +29,23 @@ #' @export #' @examples #' quantile_levels <- c(.2, .4, .6, .8) -#' predq_1 <- 1:4 # -#' predq_2 <- 8:11 -#' dstn <- dist_quantiles(list(predq_1, predq_2), quantile_levels) +#' predq1 <- 1:4 # +#' predq2 <- 8:11 +#' dstn <- quantile_pred(rbind(predq1, predq2), quantile_levels) #' actual <- c(3.3, 7.1) #' weighted_interval_score(dstn, actual) #' weighted_interval_score(dstn, actual, c(.25, .5, .75)) #' -#' library(distributional) -#' dstn <- dist_normal(c(.75, 2)) -#' weighted_interval_score(dstn, 1, c(.25, .5, .75)) -#' #' # Missing value behaviours -#' dstn <- dist_quantiles(c(1, 2, NA, 4), 1:4 / 5) +#' dstn <- quantile_pred(matrix(c(1, 2, NA, 4), nrow = 1), 1:4 / 5) #' weighted_interval_score(dstn, 2.5) #' weighted_interval_score(dstn, 2.5, 1:9 / 10) #' weighted_interval_score(dstn, 2.5, 1:9 / 10, na_handling = "drop") #' weighted_interval_score(dstn, 2.5, na_handling = "propagate") -#' weighted_interval_score(dist_quantiles(1:4, 1:4 / 5), 2.5, 1:9 / 10, +#' weighted_interval_score( +#' quantile_pred(matrix(1:4, nrow = 1), 1:4 / 5), +#' actual = 2.5, +#' quantile_levels = 1:9 / 10, #' na_handling = "fail" #' ) #' @@ -112,7 +110,7 @@ weighted_interval_score.quantile_pred <- function( } tau <- quantile_levels %||% old_quantile_levels x <- extrapolate_quantiles(x, tau, replace_na = (na_handling == "impute")) - x <- as.matrix(x)[, attr(x, "quantile_levels") %in% tau] + x <- as.matrix(x)[, attr(x, "quantile_levels") %in% tau, drop = FALSE] na_rm <- (na_handling == "drop") map2_dbl(vctrs::vec_chop(x), actual, ~ wis_one_quantile(.x, tau, .y, na_rm)) } diff --git a/man/extrapolate_quantiles.Rd b/man/extrapolate_quantiles.Rd index 4b1d1282c..b645b85fa 100644 --- a/man/extrapolate_quantiles.Rd +++ b/man/extrapolate_quantiles.Rd @@ -7,37 +7,29 @@ extrapolate_quantiles(x, probs, replace_na = TRUE, ...) } \arguments{ -\item{x}{a \code{distribution} vector} +\item{x}{A vector of class \code{quantile_pred}.} \item{probs}{a vector of probabilities at which to calculate quantiles} \item{replace_na}{logical. If \code{x} contains \code{NA}'s, these are imputed if -possible (if \code{TRUE}) or retained (if \code{FALSE}). This only effects -elements of class \code{dist_quantiles}.} +possible (if \code{TRUE}) or retained (if \code{FALSE}).} \item{...}{additional arguments passed on to the \code{quantile} method} } \value{ -a \code{distribution} vector containing \code{dist_quantiles}. Any elements -of \code{x} which were originally \code{dist_quantiles} will now have a superset +a \code{quantile_pred} vector. Each element +of \code{x} will now have a superset of the original \code{quantile_values} (the union of those and \code{probs}). } \description{ -Summarize a distribution with a set of quantiles +This function takes a \code{quantile_pred} vector and returns the same +type of object, expanded to include +\emph{additional} quantiles computed at \code{probs}. If you want behaviour more +similar to \code{\link[stats:quantile]{stats::quantile()}}, then \code{quantile(x,...)} may be more +appropriate. } \examples{ -library(distributional) -dstn <- dist_normal(c(10, 2), c(5, 10)) -extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) - -dstn <- dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) -# because this distribution is already quantiles, any extra quantiles are -# appended -extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) - -dstn <- c( - dist_normal(c(10, 2), c(5, 10)), - dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8))) -) -extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)) +dstn <- quantile_dstn(rbind(1:4, 8:11), c(.2, .4, .6, .8)) +# extra quantiles are appended +as.tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))) } diff --git a/man/flusight_hub_formatter.Rd b/man/flusight_hub_formatter.Rd index b43bc0ac2..b1b4a2435 100644 --- a/man/flusight_hub_formatter.Rd +++ b/man/flusight_hub_formatter.Rd @@ -52,11 +52,11 @@ weekly_deaths <- case_death_rate_subset \%>\% mutate(deaths = pmax(death_rate / 1e5 * pop * 7, 0)) \%>\% select(-pop, -death_rate) \%>\% group_by(geo_value) \%>\% - epi_slide(~ sum(.$deaths), before = 6, new_col_name = "deaths") \%>\% + epi_slide(~ sum(.$deaths), .window_size = 7, .new_col_name = "deaths_sum") \%>\% ungroup() \%>\% filter(weekdays(time_value) == "Saturday") -cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths") +cdc <- cdc_baseline_forecaster(weekly_deaths, "deaths_sum") flusight_hub_formatter(cdc) flusight_hub_formatter(cdc, target = "wk inc covid deaths") flusight_hub_formatter(cdc, target = paste(horizon, "wk inc covid deaths")) diff --git a/man/layer_cdc_flatline_quantiles.Rd b/man/layer_cdc_flatline_quantiles.Rd index ac3e1758b..dcd93ba91 100644 --- a/man/layer_cdc_flatline_quantiles.Rd +++ b/man/layer_cdc_flatline_quantiles.Rd @@ -62,7 +62,7 @@ an updated \code{frosting} postprocessor. Calling \code{\link[=predict]{predict( in an additional \verb{} named \code{.pred_distn_all} containing 2-column \code{\link[tibble:tibble]{tibble::tibble()}}'s. For each desired combination of \code{key}'s, the tibble will contain one row per ahead -with the associated \code{\link[=dist_quantiles]{dist_quantiles()}}. +with the associated \code{\link[=quantile_pred]{quantile_pred()}}. } \description{ This layer creates quantile forecasts by taking a sample from the diff --git a/man/nested_quantiles.Rd b/man/nested_quantiles.Rd deleted file mode 100644 index b34b718ca..000000000 --- a/man/nested_quantiles.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pivot_quantiles.R -\name{nested_quantiles} -\alias{nested_quantiles} -\title{Turn a vector of quantile distributions into a list-col} -\usage{ -nested_quantiles(x) -} -\arguments{ -\item{x}{a \code{distribution} containing \code{dist_quantiles}} -} -\value{ -a list-col -} -\description{ -Turn a vector of quantile distributions into a list-col -} -\examples{ -library(dplyr) -library(tidyr) -edf <- case_death_rate_subset[1:3, ] -edf$q <- dist_quantiles(list(1:5, 2:4, 3:10), list(1:5 / 6, 2:4 / 5, 3:10 / 11)) - -edf_nested <- edf \%>\% mutate(q = nested_quantiles(q)) -edf_nested \%>\% unnest(q) -} diff --git a/man/pivot_quantiles_longer.Rd b/man/pivot_quantiles_longer.Rd index 9879d5d07..d124defa4 100644 --- a/man/pivot_quantiles_longer.Rd +++ b/man/pivot_quantiles_longer.Rd @@ -2,41 +2,34 @@ % Please edit documentation in R/pivot_quantiles.R \name{pivot_quantiles_longer} \alias{pivot_quantiles_longer} -\title{Pivot columns containing \code{dist_quantile} longer} +\title{Pivot a column containing \code{quantile_pred} longer} \usage{ -pivot_quantiles_longer(.data, ..., .ignore_length_check = FALSE) +pivot_quantiles_longer(.data, ...) } \arguments{ \item{.data}{A data frame, or a data frame extension such as a tibble or epi_df.} -\item{...}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One or more unquoted +\item{...}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expressions separated by commas. Variable names can be used as if they were positions in the data frame, so expressions like \code{x:y} can -be used to select a range of variables.} - -\item{.ignore_length_check}{If multiple columns are selected, as long as -each row has contains the same number of quantiles, the result will be -reasonable. But if, for example, \code{var1[1]} has 5 quantiles while \code{var2[1]} -has 7, then the only option would be to recycle everything, creating a -\emph{very} long result. By default, this would throw an error. But if this is -really the goal, then the error can be bypassed by setting this argument -to \code{TRUE}. The quantiles in the first selected column will vary the fastest.} +be used to select a range of variables. Note that only one variable +can be selected for this operation} } \value{ An object of the same class as \code{.data}. } \description{ -Selected columns that contain \code{dist_quantiles} will be "lengthened" with +A column that contains \code{quantile_pred} will be "lengthened" with the quantile levels serving as 1 column and the values as another. If multiple columns are selected, these will be prefixed with the column name. } \examples{ -d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 1:3 / 4)) -d2 <- c(dist_quantiles(2:4, 2:4 / 5), dist_quantiles(3:5, 2:4 / 5)) +d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4) +d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5) tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2) pivot_quantiles_longer(tib, "d1") pivot_quantiles_longer(tib, dplyr::ends_with("1")) -pivot_quantiles_longer(tib, d1, d2) +pivot_quantiles_longer(tib, d2) } diff --git a/man/pivot_quantiles_wider.Rd b/man/pivot_quantiles_wider.Rd index e477777ca..1ce683c91 100644 --- a/man/pivot_quantiles_wider.Rd +++ b/man/pivot_quantiles_wider.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/pivot_quantiles.R \name{pivot_quantiles_wider} \alias{pivot_quantiles_wider} -\title{Pivot columns containing \code{dist_quantile} wider} +\title{Pivot a column containing \code{quantile_pred} wider} \usage{ pivot_quantiles_wider(.data, ...) } @@ -10,26 +10,27 @@ pivot_quantiles_wider(.data, ...) \item{.data}{A data frame, or a data frame extension such as a tibble or epi_df.} -\item{...}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One or more unquoted +\item{...}{<\code{\link[dplyr:dplyr_tidy_select]{tidy-select}}> One unquoted expressions separated by commas. Variable names can be used as if they were positions in the data frame, so expressions like \code{x:y} can -be used to select a range of variables.} +be used to select a range of variables. Note that only one variable +can be selected for this operation} } \value{ An object of the same class as \code{.data} } \description{ -Any selected columns that contain \code{dist_quantiles} will be "widened" with +Any selected columns that contain \code{quantile_pred} will be "widened" with the "taus" (quantile) serving as names and the values in the data frame. When pivoting multiple columns, the original column name will be used as a prefix. } \examples{ -d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 1:3 / 4)) -d2 <- c(dist_quantiles(2:4, 2:4 / 5), dist_quantiles(3:5, 2:4 / 5)) -tib <- tibble::tibble(g = c("a", "b"), d1 = d1, d2 = d2) +d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4) +d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5) +tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2) -pivot_quantiles_wider(tib, c("d1", "d2")) -pivot_quantiles_wider(tib, dplyr::starts_with("d")) +pivot_quantiles_wider(tib, "d1") +pivot_quantiles_wider(tib, dplyr::ends_with("2")) pivot_quantiles_wider(tib, d2) } diff --git a/man/smooth_quantile_reg.Rd b/man/smooth_quantile_reg.Rd index c6b17dd86..7475b6f2c 100644 --- a/man/smooth_quantile_reg.Rd +++ b/man/smooth_quantile_reg.Rd @@ -62,13 +62,12 @@ pl <- predict( ) pl <- pl \%>\% unnest(.pred) \%>\% - mutate(distn = nested_quantiles(distn)) \%>\% - unnest(distn) \%>\% + pivot_quantiles_longer(distn) \%>\% mutate( x = x[length(x) - 20] + ahead / 100 * 2 * pi, ahead = NULL ) \%>\% - pivot_wider(names_from = quantile_levels, values_from = values) + pivot_wider(names_from = distn_quantile_level, values_from = distn_value) plot(x, y, pch = 16, xlim = c(pi, 2 * pi), col = "lightgrey") curve(sin(x), add = TRUE) abline(v = fd, lty = 2) diff --git a/man/weighted_interval_score.Rd b/man/weighted_interval_score.Rd index 4b7c796ea..22a616b70 100644 --- a/man/weighted_interval_score.Rd +++ b/man/weighted_interval_score.Rd @@ -13,25 +13,24 @@ weighted_interval_score( ) } \arguments{ -\item{x}{distribution. A vector of class distribution. Ideally, this vector -contains \code{dist_quantiles()}, though other distributions are supported when -\code{quantile_levels} is specified. See below.} +\item{x}{A vector of class \code{quantile_pred}.} \item{actual}{double. Actual value(s)} \item{quantile_levels}{probabilities. If specified, the score will be -computed at this set of levels.} +computed at this set of levels. Otherwise, those present in \code{x} will be +used.} -\item{na_handling}{character. Determines how \code{quantile_levels} without a -corresponding \code{value} are handled. For \code{"impute"}, missing values will be +\item{na_handling}{character. Determines missing values are handled. +For \code{"impute"}, missing values will be calculated if possible using the available quantiles. For \code{"drop"}, explicitly missing values are ignored in the calculation of the score, but implicitly missing values are imputed if possible. For \code{"propogate"}, the resulting score will be \code{NA} if any missing values -exist in the original \code{quantile_levels}. Finally, if +exist. Finally, if \code{quantile_levels} is specified, \code{"fail"} will result in the score being \code{NA} when any required quantile levels (implicit or explicit) -are do not have corresponding values.} +do not have corresponding values.} \item{...}{not used} } @@ -47,24 +46,23 @@ of COVID-19 forecasting. } \examples{ quantile_levels <- c(.2, .4, .6, .8) -predq_1 <- 1:4 # -predq_2 <- 8:11 -dstn <- dist_quantiles(list(predq_1, predq_2), quantile_levels) +predq1 <- 1:4 # +predq2 <- 8:11 +dstn <- quantile_pred(rbind(predq1, predq2), quantile_levels) actual <- c(3.3, 7.1) weighted_interval_score(dstn, actual) weighted_interval_score(dstn, actual, c(.25, .5, .75)) -library(distributional) -dstn <- dist_normal(c(.75, 2)) -weighted_interval_score(dstn, 1, c(.25, .5, .75)) - # Missing value behaviours -dstn <- dist_quantiles(c(1, 2, NA, 4), 1:4 / 5) +dstn <- quantile_pred(matrix(c(1, 2, NA, 4), nrow = 1), 1:4 / 5) weighted_interval_score(dstn, 2.5) weighted_interval_score(dstn, 2.5, 1:9 / 10) weighted_interval_score(dstn, 2.5, 1:9 / 10, na_handling = "drop") weighted_interval_score(dstn, 2.5, na_handling = "propagate") -weighted_interval_score(dist_quantiles(1:4, 1:4 / 5), 2.5, 1:9 / 10, +weighted_interval_score( + quantile_pred(matrix(1:4, nrow = 1), 1:4 / 5), + actual = 2.5, + quantile_levels = 1:9 / 10, na_handling = "fail" ) diff --git a/tests/testthat/_snaps/pivot_quantiles.md b/tests/testthat/_snaps/pivot_quantiles.md new file mode 100644 index 000000000..13dd81916 --- /dev/null +++ b/tests/testthat/_snaps/pivot_quantiles.md @@ -0,0 +1,40 @@ +# quantile pivotting wider behaves + + Code + pivot_quantiles_wider(tib, a) + Condition + Error in `pivot_quantiles_wider()`: + ! `a` is not <`quantile_pred`>. Cannot pivot it. + +--- + + Code + pivot_quantiles_wider(tib, d1, d2) + Condition + Error in `pivot_quantiles_wider()`: + ! Only one column can be pivotted. Can not pivot all of: `d1` and `d2`. + +--- + + Code + pivot_quantiles_longer(tib, d1, d2) + Condition + Error in `pivot_quantiles_longer()`: + ! Only one column can be pivotted. Can not pivot all of: `d1` and `d2`. + +# quantile pivotting longer behaves + + Code + pivot_quantiles_longer(tib, a) + Condition + Error in `pivot_quantiles_longer()`: + ! `a` is not <`quantile_pred`>. Cannot pivot it. + +--- + + Code + pivot_quantiles_longer(tib, d1, d2) + Condition + Error in `pivot_quantiles_longer()`: + ! Only one column can be pivotted. Can not pivot all of: `d1` and `d2`. + diff --git a/tests/testthat/_snaps/quantile_pred.md b/tests/testthat/_snaps/quantile_pred.md new file mode 100644 index 000000000..dd13dcb86 --- /dev/null +++ b/tests/testthat/_snaps/quantile_pred.md @@ -0,0 +1,8 @@ +# arithmetic works on quantiles + + Code + sum(dstn) + Condition + Error in `vec_math()`: + ! `sum()` is not a supported operation for . + diff --git a/tests/testthat/_snaps/wis-quantile_pred.md b/tests/testthat/_snaps/wis-quantile_pred.md new file mode 100644 index 000000000..71f093607 --- /dev/null +++ b/tests/testthat/_snaps/wis-quantile_pred.md @@ -0,0 +1,16 @@ +# wis dispatches and produces the correct values + + Code + weighted_interval_score(1:10, 10) + Condition + Error in `weighted_interval_score()`: + ! Weighted interval score can only be calculated if `x` has class . + +--- + + Code + weighted_interval_score(quantile_pred(rbind(1:4, 8:11), 1:4 / 5), 1:3) + Condition + Error in `weighted_interval_score.quantile_pred()`: + ! Assertion on 'actual' failed: Must have length 2, but has length 3. + diff --git a/tests/testthat/test-layer_residual_quantiles.R b/tests/testthat/test-layer_residual_quantiles.R index c2b9aa198..ff6890073 100644 --- a/tests/testthat/test-layer_residual_quantiles.R +++ b/tests/testthat/test-layer_residual_quantiles.R @@ -23,11 +23,10 @@ test_that("Returns expected number or rows and columns", { expect_equal(nrow(p), 3L) expect_named(p, c("geo_value", "time_value", ".pred", ".pred_distn")) - nested <- p %>% dplyr::mutate(.quantiles = nested_quantiles(.pred_distn)) - unnested <- nested %>% tidyr::unnest(.quantiles) + unnested <- p %>% pivot_quantiles_longer(.pred_distn) expect_equal(nrow(unnested), 9L) - expect_equal(unique(unnested$quantile_levels), c(.0275, .8, .95)) + expect_equal(unique(unnested$.pred_distn_quantile_level), c(.0275, .8, .95)) }) diff --git a/tests/testthat/test-layer_threshold_preds.R b/tests/testthat/test-layer_threshold_preds.R index f051913f9..6d0f177a9 100644 --- a/tests/testthat/test-layer_threshold_preds.R +++ b/tests/testthat/test-layer_threshold_preds.R @@ -56,8 +56,7 @@ test_that("thresholds additional columns", { expect_equal(round(p$.pred, digits = 3), c(0.180, 0.180, 0.310)) expect_named(p, c("geo_value", "time_value", ".pred", ".pred_distn")) p <- p %>% - dplyr::mutate(.quantiles = nested_quantiles(.pred_distn)) %>% - tidyr::unnest(.quantiles) - expect_equal(round(p$values, digits = 3), c(0.180, 0.31, 0.180, .18, 0.310, .31)) - expect_equal(p$quantile_levels, rep(c(.1, .9), times = 3)) + pivot_quantiles_longer(.pred_distn) + expect_equal(round(p$.pred_distn_value, digits = 3), c(0.180, 0.31, 0.180, .18, 0.310, .31)) + expect_equal(p$.pred_distn_quantile_level, rep(c(.1, .9), times = 3)) }) diff --git a/tests/testthat/test-pivot_quantiles.R b/tests/testthat/test-pivot_quantiles.R index d1f092c0e..a4362cffb 100644 --- a/tests/testthat/test-pivot_quantiles.R +++ b/tests/testthat/test-pivot_quantiles.R @@ -1,76 +1,44 @@ test_that("quantile pivotting wider behaves", { tib <- tibble::tibble(a = 1:5, b = 6:10) - expect_error(pivot_quantiles_wider(tib, a)) - tib$c <- rep(dist_normal(), 5) - expect_error(pivot_quantiles_wider(tib, c)) + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, a)) - d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:5, 1:4 / 5)) - # different quantiles - tib <- tib[1:2, ] - tib$d1 <- d1 - expect_error(pivot_quantiles_wider(tib, d1)) - - d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 2:4 / 4)) - tib$d1 <- d1 - # would want to error (mismatched quantiles), but hard to check efficiently - expect_silent(pivot_quantiles_wider(tib, d1)) + d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4) + d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5) + tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2) - d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 1:3 / 4)) - d2 <- c(dist_quantiles(2:4, 2:4 / 5), dist_quantiles(3:5, 2:4 / 5)) - tib <- tibble::tibble(g = c("a", "b"), d1 = d1, d2 = d2) + # too many columns + expect_snapshot(error = TRUE, pivot_quantiles_wider(tib, d1, d2)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, d1, d2)) - expect_length(pivot_quantiles_wider(tib, c("d1", "d2")), 7L) - expect_length(pivot_quantiles_wider(tib, tidyselect::starts_with("d")), 7L) - expect_length(pivot_quantiles_wider(tib, d2), 5L) + expect_length(pivot_quantiles_wider(tib, d1), 5L) + expect_length(pivot_quantiles_wider(tib, tidyselect::ends_with("1")), 5L) + expect_equal(vctrs::vec_size(pivot_quantiles_longer(tib, d2)), 6L) }) test_that("pivotting wider still works if there are duplicates", { # previously this would produce a warning if pivotted because the # two rows of the result are identical - tb <- tibble(.pred = dist_quantiles(list(1:3, 1:3), list(c(.1, .5, .9)))) + tb <- tibble(.pred = quantile_pred(rbind(1:3, 1:3), c(.1, .5, .9))) res <- tibble(`0.1` = c(1, 1), `0.5` = c(2, 2), `0.9` = c(3, 3)) - expect_identical(tb %>% pivot_quantiles_wider(.pred), res) + expect_equal(tb %>% pivot_quantiles_wider(.pred), res) }) test_that("quantile pivotting longer behaves", { tib <- tibble::tibble(a = 1:5, b = 6:10) - expect_error(pivot_quantiles_longer(tib, a)) - tib$c <- rep(dist_normal(), 5) - expect_error(pivot_quantiles_longer(tib, c)) - - d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:5, 1:4 / 5)) - # different quantiles - tib <- tib[1:2, ] - tib$d1 <- d1 - expect_length(pivot_quantiles_longer(tib, d1), 5L) - expect_identical(nrow(pivot_quantiles_longer(tib, d1)), 7L) - expect_identical(pivot_quantiles_longer(tib, d1)$values, as.double(c(1:3, 2:5))) - - d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 2:4 / 4)) - tib$d1 <- d1 - expect_silent(pivot_quantiles_longer(tib, d1)) + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, a)) - d1 <- c(dist_quantiles(1:3, 1:3 / 4), dist_quantiles(2:4, 1:3 / 4)) - d2 <- c(dist_quantiles(2:4, 2:4 / 5), dist_quantiles(3:5, 2:4 / 5)) - tib <- tibble::tibble(g = c("a", "b"), d1 = d1, d2 = d2) + d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4) + d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5) + tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2) + # too many columns + expect_snapshot(error = TRUE, pivot_quantiles_longer(tib, d1, d2)) - expect_length(pivot_quantiles_longer(tib, c("d1", "d2")), 5L) - expect_identical(nrow(pivot_quantiles_longer(tib, c("d1", "d2"))), 6L) - expect_silent(pivot_quantiles_longer(tib, tidyselect::starts_with("d"))) - expect_length(pivot_quantiles_longer(tib, d2), 4L) + # different quantiles + expect_length(pivot_quantiles_longer(tib, d1), 4L) + expect_identical(nrow(pivot_quantiles_longer(tib, d1)), 6L) + expect_identical(pivot_quantiles_longer(tib, d1)$d1_value, c(1:3, 2:4)) - tib$d3 <- c(dist_quantiles(2:5, 2:5 / 6), dist_quantiles(3:6, 2:5 / 6)) - # now the cols have different numbers of quantiles - expect_error(pivot_quantiles_longer(tib, d1, d3)) - expect_length( - pivot_quantiles_longer(tib, d1, d3, .ignore_length_check = TRUE), - 6L - ) - expect_identical( - pivot_quantiles_longer(tib, d1, d3, .ignore_length_check = TRUE)$d1_values, - as.double(rep(c(1:3, 2:4), each = 4)) - ) }) diff --git a/tests/testthat/test-wis-dist-quantiles.R b/tests/testthat/test-wis-quantile_pred.R similarity index 60% rename from tests/testthat/test-wis-dist-quantiles.R rename to tests/testthat/test-wis-quantile_pred.R index 93f7c50eb..187344af9 100644 --- a/tests/testthat/test-wis-dist-quantiles.R +++ b/tests/testthat/test-wis-quantile_pred.R @@ -8,45 +8,38 @@ test_that("wis dispatches and produces the correct values", { actual <- 5 expected <- c(wis_one_pred(q1, tau, actual), wis_one_pred(q2, tau, actual)) - dstn <- dist_quantiles(list(q1, q2), tau) + dstn <- quantile_pred(rbind(q1, q2), tau) expect_equal(weighted_interval_score(dstn, actual), expected) # works with a single dstn q <- sort(10 * rexp(23)) tau0 <- c(.01, .025, 1:19 / 20, .975, .99) - dst <- dist_quantiles(q, tau0) + dst <- quantile_pred(rbind(q), tau0) expect_equal(weighted_interval_score(dst, 10), wis_one_pred(q, tau0, 10)) # returns NA when expected - dst <- dist_quantiles(rep(NA, 3), c(.2, .5, .95)) + dst <- quantile_pred(rbind(rep(NA, 3)), c(.2, .5, .95)) expect_true(is.na(weighted_interval_score(dst, 10))) expect_equal( weighted_interval_score(dstn, c(NA, actual)), c(NA, wis_one_pred(q2, tau, actual)) ) - # errors for non distributions - expect_error(weighted_interval_score(1:10, 10)) - expect_warning(w <- weighted_interval_score(dist_normal(1), 10)) - expect_true(all(is.na(w))) - expect_warning(w <- weighted_interval_score( - c(dist_normal(), dist_quantiles(1:5, 1:5 / 6)), - 10 - )) - expect_equal(w, c(NA, wis_one_pred(1:5, 1:5 / 6, 10))) + # errors for non quantile_pred + expect_snapshot(error = TRUE, weighted_interval_score(1:10, 10)) # errors if sizes don't match - expect_error(weighted_interval_score( - dist_quantiles(list(1:4, 8:11), 1:4 / 5), # length 2 + expect_snapshot(error = TRUE, weighted_interval_score( + quantile_pred(rbind(1:4, 8:11), 1:4 / 5), # length 2 1:3 )) #' # Missing value behaviours - dstn <- dist_quantiles(c(1, 2, NA, 4), 1:4 / 5) + dstn <- quantile_pred(rbind(c(1, 2, NA, 4)), 1:4 / 5) expect_equal(weighted_interval_score(dstn, 2.5), 0.5) expect_equal(weighted_interval_score(dstn, 2.5, c(2, 4, 5, 6, 8) / 10), 0.4) expect_equal( - weighted_interval_score(dist_quantiles(c(1, 2, NA, 4), 1:4 / 5), 3, na_handling = "drop"), + weighted_interval_score(dstn, 3, na_handling = "drop"), 2 / 3 ) expect_equal( @@ -56,5 +49,9 @@ test_that("wis dispatches and produces the correct values", { expect_true(is.na( weighted_interval_score(dstn, 2.5, na_handling = "propagate") )) - weighted_interval_score(dist_quantiles(1:4, 1:4 / 5), 2.5, 1:9 / 10, na_handling = "fail") + expect_true(is.na( + weighted_interval_score( + quantile_pred(rbind(1:4), 1:4 / 5), 2.5, 1:9 / 10, na_handling = "fail" + ) + )) }) From 87e5163b95e173dd27b6c9b62166c888be2ae781 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 17:29:27 -0700 Subject: [PATCH 35/37] all tests pass --- R/epi_recipe.R | 8 +- R/recipe.epi_df.R | 2 +- tests/testthat/_snaps/arg_is_.md | 2 +- tests/testthat/_snaps/bake-method.md | 2 +- .../_snaps/check_enough_train_data.md | 31 +- tests/testthat/_snaps/dist_quantiles.md | 56 - tests/testthat/_snaps/epi_recipe.md | 24 - tests/testthat/_snaps/epi_workflow.md | 16 - tests/testthat/_snaps/pivot_quantiles.md | 42 - tests/testthat/_snaps/population_scaling.md | 3 +- tests/testthat/_snaps/snapshots.md | 1333 ++++++----------- tests/testthat/_snaps/step_epi_shift.md | 11 +- tests/testthat/_snaps/step_epi_slide.md | 15 +- tests/testthat/_snaps/wis-dist-quantiles.md | 17 - tests/testthat/test-arg_is_.R | 2 +- tests/testthat/test-check_enough_train_data.R | 10 +- tests/testthat/test-epi_workflow.R | 7 +- tests/testthat/test-key_colnames.R | 2 +- tests/testthat/test-population_scaling.R | 2 +- tests/testthat/test-step_epi_shift.R | 6 +- tests/testthat/test-step_epi_slide.R | 4 +- tests/testthat/test-step_training_window.R | 2 +- 22 files changed, 519 insertions(+), 1078 deletions(-) delete mode 100644 tests/testthat/_snaps/dist_quantiles.md delete mode 100644 tests/testthat/_snaps/wis-dist-quantiles.md diff --git a/R/epi_recipe.R b/R/epi_recipe.R index c3a18d3cb..3cb742350 100644 --- a/R/epi_recipe.R +++ b/R/epi_recipe.R @@ -1,7 +1,11 @@ #' @import recipes #' @export epi_recipe <- function(x, ...) { - deprecate_soft("This function is being deprecated. Use `recipe()` instead.") + lifecycle::deprecate_soft( + when = "0.2.0", + what = "epi_recipe()", + with = "recipe()" + ) UseMethod("epi_recipe") } @@ -280,7 +284,7 @@ bake.epi_recipe <- function(object, new_data, ..., composition = "epi_df") { new_data, as_of = meta$as_of, # avoid NULL if meta is from saved older epi_df: - additional_metadata = meta$additional_metadata %||% list() + other_keys = meta$other_keys %||% character(0L) ) } new_data diff --git a/R/recipe.epi_df.R b/R/recipe.epi_df.R index 6cfcf3170..4187ec6af 100644 --- a/R/recipe.epi_df.R +++ b/R/recipe.epi_df.R @@ -74,7 +74,7 @@ recipe.formula <- function(formula, data, ...) { add_epi_df_roles_to_recipe <- function(r, epi_df) { edf_keys <- key_colnames(epi_df) - edf_roles <- c("geo_value", "time_value", rep("key", length(edf_keys) - 2)) + edf_roles <- c("geo_value", rep("key", length(edf_keys) - 2), "time_value") types <- unname(lapply(epi_df[, edf_keys], recipes::.get_data_types)) info <- tibble( variable = edf_keys, diff --git a/tests/testthat/_snaps/arg_is_.md b/tests/testthat/_snaps/arg_is_.md index fcb823f2a..905599fb6 100644 --- a/tests/testthat/_snaps/arg_is_.md +++ b/tests/testthat/_snaps/arg_is_.md @@ -377,7 +377,7 @@ # simple surface step test Code - epi_recipe(jhu_csse_daily_subset) %>% step_epi_lag(death_rate, lag = "hello") + 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/_snaps/bake-method.md b/tests/testthat/_snaps/bake-method.md index eee28cc4b..6ed38ab5d 100644 --- a/tests/testthat/_snaps/bake-method.md +++ b/tests/testthat/_snaps/bake-method.md @@ -5,5 +5,5 @@ Condition Error in `hardhat::recompose()`: ! `data` must only contain numeric columns. - i These columns aren't numeric: "geo_value" and "time_value". + i These columns aren't numeric: "time_value" and "geo_value". diff --git a/tests/testthat/_snaps/check_enough_train_data.md b/tests/testthat/_snaps/check_enough_train_data.md index 8f2389acb..2cdf5bcb8 100644 --- a/tests/testthat/_snaps/check_enough_train_data.md +++ b/tests/testthat/_snaps/check_enough_train_data.md @@ -1,46 +1,51 @@ # check_enough_train_data works on pooled data Code - epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, - drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, drop_na = FALSE) %>% + prep(toy_epi_df) %>% bake(new_data = NULL) Condition - Error in `prep()`: + Error in `check_enough_train_data()`: + Caused by error in `prep()`: ! The following columns don't have enough data to predict: x and y. --- Code - epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, - drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, drop_na = TRUE) %>% + prep(toy_epi_df) %>% bake(new_data = NULL) Condition - Error in `prep()`: + Error in `check_enough_train_data()`: + Caused by error in `prep()`: ! The following columns don't have enough data to predict: x and y. # check_enough_train_data works on unpooled data Code - epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) Condition - Error in `prep()`: + Error in `check_enough_train_data()`: + Caused by error in `prep()`: ! The following columns don't have enough data to predict: x and y. --- Code - epi_recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, - epi_keys = "geo_value", drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, epi_keys = "geo_value", + drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) Condition - Error in `prep()`: + Error in `check_enough_train_data()`: + Caused by error in `prep()`: ! The following columns don't have enough data to predict: x and y. # check_enough_train_data works with all_predictors() downstream of constructed terms Code - epi_recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% + recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% check_enough_train_data(all_predictors(), y, n = 2 * n - 5) %>% prep( toy_epi_df) %>% bake(new_data = NULL) Condition - Error in `prep()`: + Error in `check_enough_train_data()`: + Caused by error in `prep()`: ! The following columns don't have enough data to predict: lag_1_x, lag_2_x, and y. diff --git a/tests/testthat/_snaps/dist_quantiles.md b/tests/testthat/_snaps/dist_quantiles.md deleted file mode 100644 index 1d626e089..000000000 --- a/tests/testthat/_snaps/dist_quantiles.md +++ /dev/null @@ -1,56 +0,0 @@ -# constructor returns reasonable quantiles - - Code - new_quantiles(rnorm(5), c(-2, -1, 0, 1, 2)) - Condition - Error in `new_quantiles()`: - ! `quantile_levels` must lie in [0, 1]. - ---- - - Code - new_quantiles(sort(rnorm(5)), sort(runif(2))) - Condition - Error in `new_quantiles()`: - ! length(values) == length(quantile_levels) is not TRUE - ---- - - Code - new_quantiles(c(2, 1, 3, 4, 5), c(0.1, 0.1, 0.2, 0.5, 0.8)) - Condition - Error in `new_quantiles()`: - ! !vctrs::vec_duplicate_any(quantile_levels) is not TRUE - ---- - - Code - new_quantiles(c(2, 1, 3, 4, 5), c(0.1, 0.15, 0.2, 0.5, 0.8)) - Condition - Error in `new_quantiles()`: - ! `values[order(quantile_levels)]` produces unsorted quantiles. - ---- - - Code - new_quantiles(c(1, 2, 3), c(0.1, 0.2, 3)) - Condition - Error in `new_quantiles()`: - ! `quantile_levels` must lie in [0, 1]. - -# arithmetic works on quantiles - - Code - sum(dstn) - Condition - Error in `mapply()`: - ! You can't perform arithmetic between two distributions like this. - ---- - - Code - suppressWarnings(dstn + distributional::dist_normal()) - Condition - Error: - ! non-numeric argument to binary operator - diff --git a/tests/testthat/_snaps/epi_recipe.md b/tests/testthat/_snaps/epi_recipe.md index 24b046678..b5cfed0a0 100644 --- a/tests/testthat/_snaps/epi_recipe.md +++ b/tests/testthat/_snaps/epi_recipe.md @@ -1,27 +1,3 @@ -# epi_recipe produces error if not an epi_df - - Code - epi_recipe(tib) - Condition - Error in `epi_recipe()`: - ! `x` must be an or a , not a . - ---- - - Code - epi_recipe(y ~ x, tib) - Condition - Error in `epi_recipe()`: - ! `epi_recipe()` has been called with a non- object. Use `recipe()` instead. - ---- - - Code - epi_recipe(m) - Condition - Error in `epi_recipe()`: - ! `x` must be an or a , not a . - # add/update/adjust/remove epi_recipe works as intended Code diff --git a/tests/testthat/_snaps/epi_workflow.md b/tests/testthat/_snaps/epi_workflow.md index 006333423..5a3a8f02c 100644 --- a/tests/testthat/_snaps/epi_workflow.md +++ b/tests/testthat/_snaps/epi_workflow.md @@ -15,19 +15,3 @@ ! You cannot `forecast()` a that has not been trained. i Please use `fit()` before forecasting. -# fit method does not silently drop the class - - Code - epi_recipe(y ~ x, data = tbl) - Condition - Error in `epi_recipe()`: - ! `epi_recipe()` has been called with a non- object. Use `recipe()` instead. - ---- - - Code - ewf_erec_edf %>% fit(tbl) - Condition - Error in `if (new_meta != old_meta) ...`: - ! argument is of length zero - diff --git a/tests/testthat/_snaps/pivot_quantiles.md b/tests/testthat/_snaps/pivot_quantiles.md index a26d2c64b..13dd81916 100644 --- a/tests/testthat/_snaps/pivot_quantiles.md +++ b/tests/testthat/_snaps/pivot_quantiles.md @@ -3,80 +3,38 @@ Code pivot_quantiles_wider(tib, a) Condition -<<<<<<< HEAD Error in `pivot_quantiles_wider()`: ! `a` is not <`quantile_pred`>. Cannot pivot it. -======= - Error in `UseMethod()`: - ! no applicable method for 'family' applied to an object of class "c('integer', 'numeric')" ->>>>>>> main --- Code -<<<<<<< HEAD pivot_quantiles_wider(tib, d1, d2) Condition Error in `pivot_quantiles_wider()`: ! Only one column can be pivotted. Can not pivot all of: `d1` and `d2`. -======= - pivot_quantiles_wider(tib, c) - Condition - Error in `validate_pivot_quantiles()`: - ! Variables(s) `c` are not `dist_quantiles`. Cannot pivot them. ->>>>>>> main --- Code -<<<<<<< HEAD pivot_quantiles_longer(tib, d1, d2) Condition Error in `pivot_quantiles_longer()`: ! Only one column can be pivotted. Can not pivot all of: `d1` and `d2`. -======= - pivot_quantiles_wider(tib, d1) - Condition - Error in `pivot_quantiles_wider()`: - ! Quantiles must be the same length and have the same set of taus. - i Check failed for variables(s) `d1`. ->>>>>>> main # quantile pivotting longer behaves Code pivot_quantiles_longer(tib, a) Condition -<<<<<<< HEAD Error in `pivot_quantiles_longer()`: ! `a` is not <`quantile_pred`>. Cannot pivot it. -======= - Error in `UseMethod()`: - ! no applicable method for 'family' applied to an object of class "c('integer', 'numeric')" ->>>>>>> main --- Code -<<<<<<< HEAD pivot_quantiles_longer(tib, d1, d2) Condition Error in `pivot_quantiles_longer()`: ! Only one column can be pivotted. Can not pivot all of: `d1` and `d2`. -======= - pivot_quantiles_longer(tib, c) - Condition - Error in `validate_pivot_quantiles()`: - ! Variables(s) `c` are not `dist_quantiles`. Cannot pivot them. - ---- - - Code - pivot_quantiles_longer(tib, d1, d3) - Condition - Error in `pivot_quantiles_longer()`: - ! Some selected columns contain different numbers of quantiles. - The result would be a very long . - To do this anyway, rerun with `.ignore_length_check = TRUE`. ->>>>>>> main diff --git a/tests/testthat/_snaps/population_scaling.md b/tests/testthat/_snaps/population_scaling.md index 9263e8e1e..5e73d73c9 100644 --- a/tests/testthat/_snaps/population_scaling.md +++ b/tests/testthat/_snaps/population_scaling.md @@ -3,7 +3,8 @@ Code wf <- epi_workflow(r, parsnip::linear_reg()) %>% fit(jhu) %>% add_frosting(f) Condition - Error in `hardhat::validate_column_names()`: + Error in `step_population_scaling()`: + Caused by error in `hardhat::validate_column_names()`: ! The following required columns are missing: 'a'. --- diff --git a/tests/testthat/_snaps/snapshots.md b/tests/testthat/_snaps/snapshots.md index 84abf57d2..52013816a 100644 --- a/tests/testthat/_snaps/snapshots.md +++ b/tests/testthat/_snaps/snapshots.md @@ -2,100 +2,49 @@ structure(list(geo_value = c("ca", "fl", "ga", "ny", "pa", "tx" ), .pred = c(0.1393442, 0.103199, 0.3121244, 0.4218461, 0.7319844, - 0.1975426), .pred_distn = structure(list(structure(list(values = c(0, - 0.34820911), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.31206391), quantile_levels = c(0.05, 0.95 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.10325949, 0.52098931 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.21298119, 0.63071101), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.52311949, 0.94084931 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.40640751), quantile_levels = c(0.05, 0.95 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr"))), class = c("distribution", "vctrs_vctr", "list" - )), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(18999, 18999, - 18999, 18999, 18999, 18999), class = "Date")), row.names = c(NA, + 0.1975426), .pred_distn = structure(list(c(0, 0.34820911), c(0, + 0.31206391), c(0.10325949, 0.52098931), c(0.21298119, 0.63071101 + ), c(0.52311949, 0.94084931), c(0, 0.40640751)), quantile_levels = c(0.05, + 0.95), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, + 18992, 18992, 18992, 18992, 18992), class = "Date"), target_date = structure(c(18999, + 18999, 18999, 18999, 18999, 18999), class = "Date")), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame")) --- structure(list(geo_value = c("ca", "fl", "ga", "ny", "pa", "tx" ), .pred = c(0.1393442, 0.103199, 0.3121244, 0.4218461, 0.7319844, - 0.1975426), .pred_distn = structure(list(structure(list(values = c(0.084583345, - 0.194105055), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.048438145, 0.157959855), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.257363545, 0.366885255 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.367085245, 0.476606955), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.677223545, 0.786745255 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.142781745, 0.252303455), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr"))), class = c("distribution", "vctrs_vctr", "list" - )), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(18993, 18993, - 18993, 18993, 18993, 18993), class = "Date")), row.names = c(NA, + 0.1975426), .pred_distn = structure(list(c(0.084583345, 0.194105055 + ), c(0.048438145, 0.157959855), c(0.257363545, 0.366885255), + c(0.367085245, 0.476606955), c(0.677223545, 0.786745255), + c(0.142781745, 0.252303455)), quantile_levels = c(0.05, 0.95 + ), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, + 18992, 18992, 18992, 18992, 18992), class = "Date"), target_date = structure(c(18993, + 18993, 18993, 18993, 18993, 18993), class = "Date")), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame")) --- structure(list(geo_value = c("ca", "fl", "ga", "ny", "pa", "tx" ), .pred = c(0.1393442, 0.103199, 0.3121244, 0.4218461, 0.7319844, - 0.1975426), .pred_distn = structure(list(structure(list(values = c(0, - 0.34820911), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.31206391), quantile_levels = c(0.05, 0.95 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.10325949, 0.52098931 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.21298119, 0.63071101), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.52311949, 0.94084931 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.40640751), quantile_levels = c(0.05, 0.95 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr"))), class = c("distribution", "vctrs_vctr", "list" - )), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(18999, 18999, - 18999, 18999, 18999, 18999), class = "Date")), row.names = c(NA, + 0.1975426), .pred_distn = structure(list(c(0, 0.34820911), c(0, + 0.31206391), c(0.10325949, 0.52098931), c(0.21298119, 0.63071101 + ), c(0.52311949, 0.94084931), c(0, 0.40640751)), quantile_levels = c(0.05, + 0.95), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, + 18992, 18992, 18992, 18992, 18992), class = "Date"), target_date = structure(c(18999, + 18999, 18999, 18999, 18999, 18999), class = "Date")), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame")) --- structure(list(geo_value = c("ca", "fl", "ga", "ny", "pa", "tx" ), .pred = c(0.1393442, 0.103199, 0.3121244, 0.4218461, 0.7319844, - 0.1975426), .pred_distn = structure(list(structure(list(values = c(0, - 0.34820911), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.31206391), quantile_levels = c(0.05, 0.95 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.10325949, 0.52098931 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.21298119, 0.63071101), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.52311949, 0.94084931 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.40640751), quantile_levels = c(0.05, 0.95 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr"))), class = c("distribution", "vctrs_vctr", "list" - )), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(18993, 18993, - 18993, 18993, 18993, 18993), class = "Date")), row.names = c(NA, + 0.1975426), .pred_distn = structure(list(c(0, 0.34820911), c(0, + 0.31206391), c(0.10325949, 0.52098931), c(0.21298119, 0.63071101 + ), c(0.52311949, 0.94084931), c(0, 0.40640751)), quantile_levels = c(0.05, + 0.95), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, + 18992, 18992, 18992, 18992, 18992), class = "Date"), target_date = structure(c(18993, + 18993, 18993, 18993, 18993, 18993), class = "Date")), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame")) # cdc_baseline_forecaster snapshots @@ -110,279 +59,160 @@ 0.7319844, 0.7319844, 0.7319844, 0.1975426, 0.1975426, 0.1975426, 0.1975426, 0.1975426), ahead = c(1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, - 4L, 5L, 1L, 2L, 3L, 4L, 5L), .pred_distn = structure(list(structure(list( - values = c(0, 0, 0, 0.05519342, 0.082372705, 0.0936219, 0.1048711, - 0.1157573, 0.12317806, 0.1302723, 0.1353526, 0.1393442, 0.1433358, - 0.1484161, 0.15551034, 0.1629311, 0.1738173, 0.1850665, 0.196315695, - 0.22349498, 0.309768685, 0.3567520625, 0.439580229), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0335550493877939, + 4L, 5L, 1L, 2L, 3L, 4L, 5L), .pred_distn = structure(list(c(0, + 0, 0, 0.05519342, 0.082372705, 0.0936219, 0.1048711, 0.1157573, + 0.12317806, 0.1302723, 0.1353526, 0.1393442, 0.1433358, 0.1484161, + 0.15551034, 0.1629311, 0.1738173, 0.1850665, 0.196315695, 0.22349498, + 0.309768685, 0.3567520625, 0.439580229), c(0, 0, 0, 0, 0.0335550493877939, 0.0604073208819088, 0.0796881899581496, 0.0945180888333883, 0.107218788833388, 0.118830788833388, 0.129717088833388, 0.1393442, 0.148949488833388, 0.159110072060821, 0.171080110623306, 0.184009705322953, 0.19866346102411, 0.218798896615666, 0.250961850618106, 0.300471354816148, 0.368582781136862, - 0.43909595699107, 0.520101234797705), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.0310685196688967, + 0.43909595699107, 0.520101234797705), c(0, 0, 0, 0, 0, 0.0310685196688967, 0.0565901050435504, 0.0768417663716637, 0.0947104815343153, 0.110553706525765, 0.125192081534315, 0.1393442, 0.153133424194392, 0.167807181271713, 0.183769310145952, 0.202099979390294, 0.224139947221972, 0.252840918770688, 0.291417895572206, 0.341073550318203, 0.420604597710477, 0.494523225410904, - 0.573647294116801), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.00623643594225938, 0.0360877950479505, - 0.0604332430739307, 0.0824028153516535, 0.102509343235732, - 0.121439405653606, 0.1393442, 0.15780837904264, 0.176333479766098, - 0.1971089199637, 0.219859545844459, 0.246500872561225, 0.279163385675357, - 0.320379296602716, 0.374497727839579, 0.458894379633346, - 0.535545067037845, 0.628776504364044), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0, 0.0192048017017668, - 0.0478501821296211, 0.0723167026720766, 0.0958385084225842, 0.11812331897399, - 0.1393442, 0.161074539705197, 0.184026763327133, 0.207844848454635, - 0.23407004803228, 0.265166265836908, 0.302137478236883, 0.346008752873429, - 0.403205598400084, 0.495260096430714, 0.574198142463125, 0.672941852619816 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0, 0, 0.016465765, 0.03549514, 0.05225675, 0.0644172, 0.0749343, + 0.573647294116801), c(0, 0, 0, 0, 0, 0.00623643594225938, 0.0360877950479505, + 0.0604332430739307, 0.0824028153516535, 0.102509343235732, 0.121439405653606, + 0.1393442, 0.15780837904264, 0.176333479766098, 0.1971089199637, + 0.219859545844459, 0.246500872561225, 0.279163385675357, 0.320379296602716, + 0.374497727839579, 0.458894379633346, 0.535545067037845, 0.628776504364044 + ), c(0, 0, 0, 0, 0, 0, 0.0192048017017668, 0.0478501821296211, + 0.0723167026720766, 0.0958385084225842, 0.11812331897399, 0.1393442, + 0.161074539705197, 0.184026763327133, 0.207844848454635, 0.23407004803228, + 0.265166265836908, 0.302137478236883, 0.346008752873429, 0.403205598400084, + 0.495260096430714, 0.574198142463125, 0.672941852619816), c(0, + 0, 0, 0, 0.016465765, 0.03549514, 0.05225675, 0.0644172, 0.0749343, 0.0847941, 0.0966258, 0.103199, 0.1097722, 0.1216039, 0.1314637, 0.1419808, 0.15414125, 0.17090286, 0.189932235, 0.22848398, 0.30542311, - 0.40216399, 0.512353658), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.00331296053340532, 0.0234804643776438, - 0.0414109089650896, 0.0579040140087902, 0.0738391473860739, - 0.0882882738549385, 0.103199, 0.118522737211872, 0.134217143129031, - 0.15174910202592, 0.17076597900759, 0.192368859892349, 0.218887, - 0.254338497855279, 0.307871753369934, 0.407530532639726, - 0.506824682189646, 0.607973477267732), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0, 0, - 0.0185864520320203, 0.0411215858914089, 0.062281046686267, 0.0828222124563246, - 0.103199, 0.123575888447284, 0.144785989158292, 0.167277039342293, - 0.192536265178252, 0.221677797769728, 0.256887836856768, 0.302366681512415, - 0.3669383199518, 0.476508917333523, 0.574293059865274, 0.69194511433946 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0, 0, 0, 0, 0, 0, 0.0271019287070871, 0.0535555494987951, 0.0785514374097741, - 0.103199, 0.128043832742677, 0.154157375592856, 0.181874602598776, - 0.212708648669987, 0.247608381738568, 0.289082621291513, 0.342486159511745, - 0.41300665395314, 0.52870334697862, 0.634316186092986, 0.767614547228429 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0, 0, 0, 0, 0, 0, 0.0118725894981448, 0.0439446210512103, 0.0736366703227029, - 0.103199, 0.133138617710077, 0.16357656105121, 0.19575459701827, - 0.230475760859608, 0.269323345322203, 0.314976554734947, 0.373424338576786, - 0.452807955824158, 0.578141866759416, 0.690542571738594, 0.837295153768033 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0.0813658, 0.14899276, 0.1960782, 0.22542314, 0.2414296, 0.25890318, - 0.2747762, 0.2881148, 0.3027873, 0.3121244, 0.3214615, 0.336134, - 0.3494726, 0.36534562, 0.3828192, 0.39882566, 0.4281706, 0.47525604, - 0.542883, 0.682805397499999, 0.798878314999999), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0.0706949, - 0.1267172, 0.1667331, 0.198582473624236, 0.225423180397104, 0.2494327, - 0.2707747, 0.292116312116921, 0.3121244, 0.3321324, 0.353072222341423, - 0.375089999249792, 0.3988256, 0.425831930221552, 0.459232792604326, - 0.501467782274773, 0.562188443556836, 0.685648485782108, 0.80647163752115, - 0.939224788489265), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0.0704696868359684, 0.121407167925079, - 0.161930580284053, 0.197682797539976, 0.228361656891269, - 0.257706650923509, 0.285717780926109, 0.3121244, 0.338115598498035, - 0.365749693067931, 0.395921877240673, 0.427437934626446, - 0.462388578749537, 0.504066064225642, 0.558443518811788, - 0.636013559040791, 0.771225883005179, 0.89210797204162, 1.02314875759509 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, - 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, - 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0.0247190015881658, 0.0834693973257732, - 0.131490031120311, 0.173258318827988, 0.211213742349423, - 0.246202447408474, 0.279926744217642, 0.3121244, 0.344908347408474, - 0.378255200773608, 0.412935547408474, 0.45191576510605, 0.494757615230152, - 0.545060918490786, 0.609312182129471, 0.69704881099591, 0.838550239412991, - 0.962653262246773, 1.11351403170759), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.0501392705767058, - 0.104248897713977, 0.151994400390804, 0.195087767727627, 0.235544124698047, - 0.274058107118071, 0.3121244, 0.350571341810268, 0.390274666572666, - 0.43048632300908, 0.474320393891039, 0.523839613390634, 0.581010268149082, - 0.652137495469405, 0.748428674762348, 0.898563270096551, 1.03273295410124, - 1.19211145220822), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0.2148017, 0.31250597, 0.350183905, 0.3745639, - 0.3884161, 0.39746621, 0.404854, 0.4115031, 0.417413315, - 0.4218461, 0.426278885, 0.4321891, 0.4388382, 0.44622599, - 0.4552761, 0.4691283, 0.493508295, 0.53118623, 0.628890499999999, - 1.22043540499999, 1.95905017899999), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0.212369462232823, - 0.289571577546325, 0.324446887783878, 0.351262144469445, 0.37087, - 0.3863844, 0.399682509835098, 0.411036898891089, 0.4218461, 0.432927818676137, - 0.444338520819208, 0.4573077, 0.4728222, 0.492817749438994, 0.519442857224172, - 0.556165331447064, 0.635946057886079, 1.18402232252562, 1.7827032389242, - 2.5561261649726), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.0413098183761837, 0.216633655848608, - 0.28006329699657, 0.3175577049983, 0.345923291761818, 0.368957399144641, - 0.38804556403724, 0.405400893204282, 0.4218461, 0.43864616004845, - 0.456105937661177, 0.475585378227632, 0.499018124730147, - 0.5270891900114, 0.564293444378844, 0.630730263388634, 0.898212235100651, - 1.53976520159876, 2.08228809477582, 2.80588762256078), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.114729892920429, - 0.227785958288583, 0.282278878729037, 0.320407599201492, 0.350577823459785, - 0.37665230304923, 0.39981364198757, 0.4218461, 0.444009706175862, - 0.466962725214852, 0.493098379685547, 0.523708407392674, 0.562100740111401, - 0.619050517814778, 0.754868363055733, 1.1177263295869, 1.76277018354499, - 2.37278671910076, 2.9651652434047), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0100954501382014, - 0.165091099860099, 0.244964334392844, 0.294577054174442, 0.333357739419644, - 0.365251480804308, 0.394198909379894, 0.4218461, 0.449607812233022, - 0.479120513116631, 0.511271131674317, 0.5506402899964, 0.60295411796593, - 0.690751300611906, 0.913578722060166, 1.30856988553206, 1.94020220543606, - 2.57104934168037, 3.07139639379724), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.303454977, 0.3982330425, - 0.46791125, 0.57642367, 0.631462275, 0.6694025, 0.685048, 0.69857015, - 0.7085162, 0.71633898, 0.7252792, 0.7319844, 0.7386896, 0.74762982, - 0.7554526, 0.76539865, 0.7789208, 0.7945663, 0.832506525, 0.88754513, - 0.99605755, 1.0657357575, 1.160513823), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.188727136659627, - 0.292714653217782, 0.380882595473705, 0.476427609604196, 0.5464739, - 0.6001155, 0.636506664263643, 0.6638148, 0.684726301742618, 0.701811, - 0.7174565, 0.7319844, 0.7465124, 0.7621578, 0.779322149415794, - 0.800154, 0.826981204292293, 0.8649709, 0.918345662372574, 0.987315641681917, - 1.08210087899389, 1.17564510102166, 1.27428433325155), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.0928040444059739, - 0.212569233904214, 0.310718449102641, 0.418013562853928, 0.489917936424114, - 0.546885925424654, 0.593410228218282, 0.631406259421094, 0.661579628218282, - 0.687282906872069, 0.710456666258662, 0.7319844, 0.754131389282943, - 0.776685628218282, 0.802388976168662, 0.832758896293562, 0.869440928218282, - 0.916359694097141, 0.97403912794778, 1.04529048496565, 1.15710382277548, - 1.25675656404419, 1.37098330871205), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.0108404989744699, - 0.144337973117581, 0.250292371898569, 0.367310419323293, 0.44444044802193, - 0.506592035751958, 0.558428768125431, 0.602035095628756, 0.64112383905529, - 0.674354964141041, 0.703707875219752, 0.7319844, 0.760702196782168, - 0.78975826405844, 0.823427572594726, 0.860294897090771, 0.904032120658957, - 0.955736581115011, 1.0165945004053, 1.09529786576616, 1.21614421175967, - 1.32331604019295, 1.45293812780298), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0.0783919019408445, - 0.19440762901709, 0.323264916745368, 0.407999619319143, 0.474764568463685, - 0.530890671381964, 0.580852443909739, 0.623441748828038, 0.661393469870099, - 0.69827126098506, 0.7319844, 0.766440770218252, 0.802260162496625, - 0.840536805657307, 0.883133954556946, 0.931565607767828, 0.98815401699637, - 1.05406790404239, 1.138596250043, 1.27030064370239, 1.39007785503355, - 1.5343628053761), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0.012845105, 0.07040502, 0.09495188, 0.12669976, - 0.1502248, 0.1659163, 0.1761341, 0.18586528, 0.191290375, - 0.1975426, 0.203794825, 0.20921992, 0.2189511, 0.2291689, - 0.2448604, 0.26838544, 0.30013332, 0.32468018, 0.382240095, - 0.5020427625, 0.590302013999998), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0.0133856545472455, + 0.40216399, 0.512353658), c(0, 0, 0, 0, 0, 0.00331296053340532, + 0.0234804643776438, 0.0414109089650896, 0.0579040140087902, 0.0738391473860739, + 0.0882882738549385, 0.103199, 0.118522737211872, 0.134217143129031, + 0.15174910202592, 0.17076597900759, 0.192368859892349, 0.218887, + 0.254338497855279, 0.307871753369934, 0.407530532639726, 0.506824682189646, + 0.607973477267732), c(0, 0, 0, 0, 0, 0, 0, 0.0185864520320203, + 0.0411215858914089, 0.062281046686267, 0.0828222124563246, 0.103199, + 0.123575888447284, 0.144785989158292, 0.167277039342293, 0.192536265178252, + 0.221677797769728, 0.256887836856768, 0.302366681512415, 0.3669383199518, + 0.476508917333523, 0.574293059865274, 0.69194511433946), c(0, + 0, 0, 0, 0, 0, 0, 0, 0.0271019287070871, 0.0535555494987951, + 0.0785514374097741, 0.103199, 0.128043832742677, 0.154157375592856, + 0.181874602598776, 0.212708648669987, 0.247608381738568, 0.289082621291513, + 0.342486159511745, 0.41300665395314, 0.52870334697862, 0.634316186092986, + 0.767614547228429), c(0, 0, 0, 0, 0, 0, 0, 0, 0.0118725894981448, + 0.0439446210512103, 0.0736366703227029, 0.103199, 0.133138617710077, + 0.16357656105121, 0.19575459701827, 0.230475760859608, 0.269323345322203, + 0.314976554734947, 0.373424338576786, 0.452807955824158, 0.578141866759416, + 0.690542571738594, 0.837295153768033), c(0, 0, 0.0813658, 0.14899276, + 0.1960782, 0.22542314, 0.2414296, 0.25890318, 0.2747762, 0.2881148, + 0.3027873, 0.3121244, 0.3214615, 0.336134, 0.3494726, 0.36534562, + 0.3828192, 0.39882566, 0.4281706, 0.47525604, 0.542883, 0.682805397499999, + 0.798878314999999), c(0, 0, 0, 0.0706949, 0.1267172, 0.1667331, + 0.198582473624236, 0.225423180397104, 0.2494327, 0.2707747, 0.292116312116921, + 0.3121244, 0.3321324, 0.353072222341423, 0.375089999249792, 0.3988256, + 0.425831930221552, 0.459232792604326, 0.501467782274773, 0.562188443556836, + 0.685648485782108, 0.80647163752115, 0.939224788489265), c(0, + 0, 0, 0, 0.0704696868359684, 0.121407167925079, 0.161930580284053, + 0.197682797539976, 0.228361656891269, 0.257706650923509, 0.285717780926109, + 0.3121244, 0.338115598498035, 0.365749693067931, 0.395921877240673, + 0.427437934626446, 0.462388578749537, 0.504066064225642, 0.558443518811788, + 0.636013559040791, 0.771225883005179, 0.89210797204162, 1.02314875759509 + ), c(0, 0, 0, 0, 0.0247190015881658, 0.0834693973257732, 0.131490031120311, + 0.173258318827988, 0.211213742349423, 0.246202447408474, 0.279926744217642, + 0.3121244, 0.344908347408474, 0.378255200773608, 0.412935547408474, + 0.45191576510605, 0.494757615230152, 0.545060918490786, 0.609312182129471, + 0.69704881099591, 0.838550239412991, 0.962653262246773, 1.11351403170759 + ), c(0, 0, 0, 0, 0, 0.0501392705767058, 0.104248897713977, 0.151994400390804, + 0.195087767727627, 0.235544124698047, 0.274058107118071, 0.3121244, + 0.350571341810268, 0.390274666572666, 0.43048632300908, 0.474320393891039, + 0.523839613390634, 0.581010268149082, 0.652137495469405, 0.748428674762348, + 0.898563270096551, 1.03273295410124, 1.19211145220822), c(0, + 0, 0.2148017, 0.31250597, 0.350183905, 0.3745639, 0.3884161, + 0.39746621, 0.404854, 0.4115031, 0.417413315, 0.4218461, 0.426278885, + 0.4321891, 0.4388382, 0.44622599, 0.4552761, 0.4691283, 0.493508295, + 0.53118623, 0.628890499999999, 1.22043540499999, 1.95905017899999 + ), c(0, 0, 0, 0.212369462232823, 0.289571577546325, 0.324446887783878, + 0.351262144469445, 0.37087, 0.3863844, 0.399682509835098, 0.411036898891089, + 0.4218461, 0.432927818676137, 0.444338520819208, 0.4573077, 0.4728222, + 0.492817749438994, 0.519442857224172, 0.556165331447064, 0.635946057886079, + 1.18402232252562, 1.7827032389242, 2.5561261649726), c(0, 0, + 0, 0.0413098183761837, 0.216633655848608, 0.28006329699657, 0.3175577049983, + 0.345923291761818, 0.368957399144641, 0.38804556403724, 0.405400893204282, + 0.4218461, 0.43864616004845, 0.456105937661177, 0.475585378227632, + 0.499018124730147, 0.5270891900114, 0.564293444378844, 0.630730263388634, + 0.898212235100651, 1.53976520159876, 2.08228809477582, 2.80588762256078 + ), c(0, 0, 0, 0, 0.114729892920429, 0.227785958288583, 0.282278878729037, + 0.320407599201492, 0.350577823459785, 0.37665230304923, 0.39981364198757, + 0.4218461, 0.444009706175862, 0.466962725214852, 0.493098379685547, + 0.523708407392674, 0.562100740111401, 0.619050517814778, 0.754868363055733, + 1.1177263295869, 1.76277018354499, 2.37278671910076, 2.9651652434047 + ), c(0, 0, 0, 0, 0.0100954501382014, 0.165091099860099, 0.244964334392844, + 0.294577054174442, 0.333357739419644, 0.365251480804308, 0.394198909379894, + 0.4218461, 0.449607812233022, 0.479120513116631, 0.511271131674317, + 0.5506402899964, 0.60295411796593, 0.690751300611906, 0.913578722060166, + 1.30856988553206, 1.94020220543606, 2.57104934168037, 3.07139639379724 + ), c(0.303454977, 0.3982330425, 0.46791125, 0.57642367, 0.631462275, + 0.6694025, 0.685048, 0.69857015, 0.7085162, 0.71633898, 0.7252792, + 0.7319844, 0.7386896, 0.74762982, 0.7554526, 0.76539865, 0.7789208, + 0.7945663, 0.832506525, 0.88754513, 0.99605755, 1.0657357575, + 1.160513823), c(0.188727136659627, 0.292714653217782, 0.380882595473705, + 0.476427609604196, 0.5464739, 0.6001155, 0.636506664263643, 0.6638148, + 0.684726301742618, 0.701811, 0.7174565, 0.7319844, 0.7465124, + 0.7621578, 0.779322149415794, 0.800154, 0.826981204292293, 0.8649709, + 0.918345662372574, 0.987315641681917, 1.08210087899389, 1.17564510102166, + 1.27428433325155), c(0.0928040444059739, 0.212569233904214, 0.310718449102641, + 0.418013562853928, 0.489917936424114, 0.546885925424654, 0.593410228218282, + 0.631406259421094, 0.661579628218282, 0.687282906872069, 0.710456666258662, + 0.7319844, 0.754131389282943, 0.776685628218282, 0.802388976168662, + 0.832758896293562, 0.869440928218282, 0.916359694097141, 0.97403912794778, + 1.04529048496565, 1.15710382277548, 1.25675656404419, 1.37098330871205 + ), c(0.0108404989744699, 0.144337973117581, 0.250292371898569, + 0.367310419323293, 0.44444044802193, 0.506592035751958, 0.558428768125431, + 0.602035095628756, 0.64112383905529, 0.674354964141041, 0.703707875219752, + 0.7319844, 0.760702196782168, 0.78975826405844, 0.823427572594726, + 0.860294897090771, 0.904032120658957, 0.955736581115011, 1.0165945004053, + 1.09529786576616, 1.21614421175967, 1.32331604019295, 1.45293812780298 + ), c(0, 0.0783919019408445, 0.19440762901709, 0.323264916745368, + 0.407999619319143, 0.474764568463685, 0.530890671381964, 0.580852443909739, + 0.623441748828038, 0.661393469870099, 0.69827126098506, 0.7319844, + 0.766440770218252, 0.802260162496625, 0.840536805657307, 0.883133954556946, + 0.931565607767828, 0.98815401699637, 1.05406790404239, 1.138596250043, + 1.27030064370239, 1.39007785503355, 1.5343628053761), c(0, 0, + 0.012845105, 0.07040502, 0.09495188, 0.12669976, 0.1502248, 0.1659163, + 0.1761341, 0.18586528, 0.191290375, 0.1975426, 0.203794825, 0.20921992, + 0.2189511, 0.2291689, 0.2448604, 0.26838544, 0.30013332, 0.32468018, + 0.382240095, 0.5020427625, 0.590302013999998), c(0, 0, 0, 0.0133856545472455, 0.0528330564916649, 0.0825071163605637, 0.107217748074731, 0.130397558147181, 0.151367721571716, 0.1688357, 0.183736649076791, 0.1975426, 0.2111662, 0.226622576069161, 0.244738709634746, 0.265660771838618, 0.289502, 0.3157762, 0.347933515877459, 0.395446576674467, 0.494033943284933, - 0.586036939413118, 0.696507800090321), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0119984314577645, + 0.586036939413118, 0.696507800090321), c(0, 0, 0, 0, 0.0119984314577645, 0.0497573816250162, 0.081255049503995, 0.108502307388674, 0.132961558931189, 0.156011650575706, 0.177125892134071, 0.1975426, 0.217737120618906, 0.239458499211792, 0.263562581820818, 0.289525383565136, 0.31824420000725, 0.35141305194052, 0.393862560773808, 0.453538799225292, 0.558631806850418, - 0.657452391363313, 0.767918764883928), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.0189057930465303, + 0.657452391363313, 0.767918764883928), c(0, 0, 0, 0, 0, 0.0189057930465303, 0.0558619823820737, 0.0885055048481483, 0.117823094349893, 0.145878789120691, 0.171852417645726, 0.1975426, 0.222526993865839, 0.249029206661066, 0.27731797305948, 0.306704680469104, 0.340659034209842, 0.379550761828618, 0.429562304567396, 0.499209921951019, 0.612206099576094, 0.713714149138691, - 0.835600324727346), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0.0331956220262204, 0.0710455499705998, - 0.105140687231072, 0.136976315413355, 0.167518817907279, - 0.1975426, 0.226974062486675, 0.257640196272163, 0.289459502055271, - 0.323342029611596, 0.361500312536625, 0.407123841331413, - 0.46286764504675, 0.538379175655057, 0.659249503348734, 0.768470658367656, - 0.898774707571334), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr"))), class = c("distribution", - "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, + 0.835600324727346), c(0, 0, 0, 0, 0, 0, 0.0331956220262204, 0.0710455499705998, + 0.105140687231072, 0.136976315413355, 0.167518817907279, 0.1975426, + 0.226974062486675, 0.257640196272163, 0.289459502055271, 0.323342029611596, + 0.361500312536625, 0.407123841331413, 0.46286764504675, 0.538379175655057, + 0.659249503348734, 0.768470658367656, 0.898774707571334)), quantile_levels = c(0.01, + 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, + 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 + ), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(18999, 19006, - 19013, 19020, 19027, 18999, 19006, 19013, 19020, 19027, 18999, + 18992, 18992), class = "Date"), target_date = structure(c(18999, 19006, 19013, 19020, 19027, 18999, 19006, 19013, 19020, 19027, 18999, 19006, 19013, 19020, 19027, 18999, 19006, 19013, 19020, - 19027), class = "Date")), row.names = c(NA, -30L), class = c("tbl_df", + 19027, 18999, 19006, 19013, 19020, 19027, 18999, 19006, 19013, + 19020, 19027), class = "Date")), row.names = c(NA, -30L), class = c("tbl_df", "tbl", "data.frame")) --- @@ -397,291 +227,167 @@ 0.7319844, 0.7319844, 0.7319844, 0.1975426, 0.1975426, 0.1975426, 0.1975426, 0.1975426), ahead = c(2L, 3L, 4L, 5L, 6L, 2L, 3L, 4L, 5L, 6L, 2L, 3L, 4L, 5L, 6L, 2L, 3L, 4L, 5L, 6L, 2L, 3L, 4L, - 5L, 6L, 2L, 3L, 4L, 5L, 6L), .pred_distn = structure(list(structure(list( - values = c(0, 0, 0, 0, 0.0344362435566855, 0.0610170086495865, - 0.0798865084778347, 0.0944014546310463, 0.107339121226462, - 0.11899734099851, 0.129600408649586, 0.1393442, 0.149195708649586, - 0.159627982246122, 0.170968308649587, 0.184031805880359, - 0.198909658094331, 0.219058736130861, 0.250692448549235, - 0.300646382944129, 0.368938143197633, 0.440038195052124, - 0.51997011826723), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.0303364052628526, 0.0557306728227282, - 0.0766736159703596, 0.0942284381264812, 0.11050757203172, - 0.125214601455714, 0.1393442, 0.15359732398729, 0.168500447692877, - 0.184551468093631, 0.202926420944109, 0.22476606802393, 0.253070223293233, - 0.29122995395109, 0.341963643747938, 0.419747975311502, 0.495994046054689, - 0.5748791770223), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.00603076915889168, 0.0356039073625737, - 0.0609470811194113, 0.0833232869645198, 0.103265350891109, - 0.121507077706427, 0.1393442, 0.157305073932789, 0.176004666813668, - 0.196866917086671, 0.219796529731897, 0.247137200365254, - 0.280371254591746, 0.320842872758278, 0.374783454750148, - 0.461368597638526, 0.539683256474915, 0.632562403391324), - quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, - 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0.018869505399304, 0.0471517885822858, - 0.0732707765908659, 0.0969223475714758, 0.118188509171441, - 0.1393442, 0.161036861715017, 0.183255665579256, 0.207206810683007, - 0.23409988698267, 0.265549713886389, 0.302197074524145, 0.346715970732557, - 0.40460690801818, 0.498076490174802, 0.580016068409433, 0.680138975526255 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, - 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, - 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0.00232218982614828, 0.0342017690820909, - 0.062828756299263, 0.0893725834453345, 0.114623710996309, - 0.1393442, 0.163790622390774, 0.189495107256772, 0.216754530328403, - 0.247065337260473, 0.281410456107061, 0.32037037400004, 0.367018829587046, - 0.431198706165962, 0.52829547296083, 0.619021148955337, 0.728730172315724 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, - 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, - 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.00233673672776743, 0.0223488000000001, - 0.040304673503435, 0.0576262998104982, 0.0732741199141993, - 0.088455610793058, 0.103199, 0.118707592060121, 0.134185928864089, - 0.151183139276793, 0.1702454, 0.191937, 0.2182298, 0.253577609846549, - 0.307351538752588, 0.407165223924639, 0.502529513927214, - 0.605582108686126), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0, 0.0190621000375005, 0.0420071558734088, - 0.0629230825705257, 0.0833688260410605, 0.103199, 0.124118509153392, - 0.145401945823358, 0.168667287877079, 0.1939090000375, 0.222597428173282, - 0.256984900377504, 0.301709122144422, 0.366495424858649, - 0.475152766217062, 0.572497835146252, 0.693762274318904), - quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, - 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0, 0, 0.0269530072946728, 0.0530040092850928, - 0.0782481277003769, 0.103199, 0.12816325599641, 0.154866111682517, - 0.182302899107341, 0.213783044306043, 0.248363904708547, - 0.28995690796288, 0.341627908394784, 0.413707680386504, 0.528381820556805, - 0.635771182105746, 0.77652465912812), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0, 0, + 5L, 6L, 2L, 3L, 4L, 5L, 6L), .pred_distn = structure(list(c(0, + 0, 0, 0, 0.0344362435566855, 0.0610170086495865, 0.0798865084778347, + 0.0944014546310463, 0.107339121226462, 0.11899734099851, 0.129600408649586, + 0.1393442, 0.149195708649586, 0.159627982246122, 0.170968308649587, + 0.184031805880359, 0.198909658094331, 0.219058736130861, 0.250692448549235, + 0.300646382944129, 0.368938143197633, 0.440038195052124, 0.51997011826723 + ), c(0, 0, 0, 0, 0, 0.0303364052628526, 0.0557306728227282, 0.0766736159703596, + 0.0942284381264812, 0.11050757203172, 0.125214601455714, 0.1393442, + 0.15359732398729, 0.168500447692877, 0.184551468093631, 0.202926420944109, + 0.22476606802393, 0.253070223293233, 0.29122995395109, 0.341963643747938, + 0.419747975311502, 0.495994046054689, 0.5748791770223), c(0, + 0, 0, 0, 0, 0.00603076915889168, 0.0356039073625737, 0.0609470811194113, + 0.0833232869645198, 0.103265350891109, 0.121507077706427, 0.1393442, + 0.157305073932789, 0.176004666813668, 0.196866917086671, 0.219796529731897, + 0.247137200365254, 0.280371254591746, 0.320842872758278, 0.374783454750148, + 0.461368597638526, 0.539683256474915, 0.632562403391324), c(0, + 0, 0, 0, 0, 0, 0.018869505399304, 0.0471517885822858, 0.0732707765908659, + 0.0969223475714758, 0.118188509171441, 0.1393442, 0.161036861715017, + 0.183255665579256, 0.207206810683007, 0.23409988698267, 0.265549713886389, + 0.302197074524145, 0.346715970732557, 0.40460690801818, 0.498076490174802, + 0.580016068409433, 0.680138975526255), c(0, 0, 0, 0, 0, 0, 0.00232218982614828, + 0.0342017690820909, 0.062828756299263, 0.0893725834453345, 0.114623710996309, + 0.1393442, 0.163790622390774, 0.189495107256772, 0.216754530328403, + 0.247065337260473, 0.281410456107061, 0.32037037400004, 0.367018829587046, + 0.431198706165962, 0.52829547296083, 0.619021148955337, 0.728730172315724 + ), c(0, 0, 0, 0, 0, 0.00233673672776743, 0.0223488000000001, + 0.040304673503435, 0.0576262998104982, 0.0732741199141993, 0.088455610793058, + 0.103199, 0.118707592060121, 0.134185928864089, 0.151183139276793, + 0.1702454, 0.191937, 0.2182298, 0.253577609846549, 0.307351538752588, + 0.407165223924639, 0.502529513927214, 0.605582108686126), c(0, + 0, 0, 0, 0, 0, 0, 0.0190621000375005, 0.0420071558734088, 0.0629230825705257, + 0.0833688260410605, 0.103199, 0.124118509153392, 0.145401945823358, + 0.168667287877079, 0.1939090000375, 0.222597428173282, 0.256984900377504, + 0.301709122144422, 0.366495424858649, 0.475152766217062, 0.572497835146252, + 0.693762274318904), c(0, 0, 0, 0, 0, 0, 0, 0, 0.0269530072946728, + 0.0530040092850928, 0.0782481277003769, 0.103199, 0.12816325599641, + 0.154866111682517, 0.182302899107341, 0.213783044306043, 0.248363904708547, + 0.28995690796288, 0.341627908394784, 0.413707680386504, 0.528381820556805, + 0.635771182105746, 0.77652465912812), c(0, 0, 0, 0, 0, 0, 0, 0, 0.0133969262208122, 0.0447913089328894, 0.0739787251314013, 0.103199, 0.132965213784838, 0.163644939246192, 0.196475575572506, 0.231647450729907, 0.271208219491195, 0.317741925837459, 0.376214875186902, 0.454693715463155, 0.578781950822058, 0.695278060333427, 0.835521146843828 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0, 0, 0, 0, 0, 0, 0.000725156354313476, 0.036290207696477, 0.0701157049196494, - 0.103199, 0.136581757676227, 0.170980571439515, 0.20778982998995, - 0.247087076718167, 0.291689672899979, 0.343587258527985, 0.406717577407724, - 0.490437549306793, 0.620305872542078, 0.740730855925609, 0.888992767585756 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0, 0.0701359181289814, 0.126021564763798, 0.165542973066331, - 0.197412078824538, 0.2254231, 0.24849244896414, 0.271074448350284, - 0.292116376731667, 0.3121244, 0.3321324, 0.3534741, 0.375505591313813, - 0.4001594, 0.4268368, 0.459466546351464, 0.501142770839258, 0.562143084394445, - 0.686511993260583, 0.808747521078011, 0.936070949770187), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0.00157374045240457, - 0.0698662194634446, 0.120287640452405, 0.16090076400914, 0.195966561494315, - 0.227802919628796, 0.257250456567366, 0.284352940452404, 0.3121244, - 0.338954445099751, 0.366682808562485, 0.395431772465525, 0.428410340452405, - 0.464424683613586, 0.505774640452405, 0.559060310062401, 0.635868688255882, - 0.771213743700187, 0.895124744284645, 1.02835689610128), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0203251909788099, - 0.0807941084801849, 0.131156594663197, 0.173483742579226, 0.211670557196072, - 0.246244078609487, 0.278363918673537, 0.3121244, 0.345057130768308, - 0.378403757196072, 0.414130127568126, 0.451969178608786, 0.495598517595426, - 0.545136665227352, 0.60807806098831, 0.695394235571256, 0.837130344811698, - 0.966111057134121, 1.11185508502426), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.0477276069251695, - 0.103509981435814, 0.15221877094871, 0.195952578625286, 0.236147272793828, - 0.274650521629366, 0.3121244, 0.349346986282313, 0.388561057230272, - 0.429378978625286, 0.474721256740267, 0.523806740641156, 0.581962784214742, - 0.652062951302463, 0.746838578625286, 0.896492945755508, 1.0340527654686, - 1.19219029825678), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.0166039560593608, 0.0776387168354182, - 0.132003170161801, 0.180530886857168, 0.22594722201882, 0.268822337600976, - 0.3121244, 0.354489864523245, 0.398378553881739, 0.444274543339083, - 0.494499388431484, 0.548837448212482, 0.612239188685087, - 0.690272902609576, 0.790473599123991, 0.950950996975469, - 1.09638828065763, 1.26930966690442), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0.214450885057551, - 0.288864871241312, 0.3250653, 0.3516615, 0.3716087, 0.386718885323753, - 0.399682691320713, 0.411042976158862, 0.4218461, 0.4329278, 0.444139278140181, - 0.456951313505885, 0.4720835, 0.4920307, 0.518626803531635, 0.555566110165902, - 0.636745822624727, 1.18069710590251, 1.79487371178211, 2.55270530204625 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, + ), c(0, 0, 0, 0, 0, 0, 0, 0, 0.000725156354313476, 0.036290207696477, + 0.0701157049196494, 0.103199, 0.136581757676227, 0.170980571439515, + 0.20778982998995, 0.247087076718167, 0.291689672899979, 0.343587258527985, + 0.406717577407724, 0.490437549306793, 0.620305872542078, 0.740730855925609, + 0.888992767585756), c(0, 0, 0, 0.0701359181289814, 0.126021564763798, + 0.165542973066331, 0.197412078824538, 0.2254231, 0.24849244896414, + 0.271074448350284, 0.292116376731667, 0.3121244, 0.3321324, 0.3534741, + 0.375505591313813, 0.4001594, 0.4268368, 0.459466546351464, 0.501142770839258, + 0.562143084394445, 0.686511993260583, 0.808747521078011, 0.936070949770187 + ), c(0, 0, 0, 0.00157374045240457, 0.0698662194634446, 0.120287640452405, + 0.16090076400914, 0.195966561494315, 0.227802919628796, 0.257250456567366, + 0.284352940452404, 0.3121244, 0.338954445099751, 0.366682808562485, + 0.395431772465525, 0.428410340452405, 0.464424683613586, 0.505774640452405, + 0.559060310062401, 0.635868688255882, 0.771213743700187, 0.895124744284645, + 1.02835689610128), c(0, 0, 0, 0, 0.0203251909788099, 0.0807941084801849, + 0.131156594663197, 0.173483742579226, 0.211670557196072, 0.246244078609487, + 0.278363918673537, 0.3121244, 0.345057130768308, 0.378403757196072, + 0.414130127568126, 0.451969178608786, 0.495598517595426, 0.545136665227352, + 0.60807806098831, 0.695394235571256, 0.837130344811698, 0.966111057134121, + 1.11185508502426), c(0, 0, 0, 0, 0, 0.0477276069251695, 0.103509981435814, + 0.15221877094871, 0.195952578625286, 0.236147272793828, 0.274650521629366, + 0.3121244, 0.349346986282313, 0.388561057230272, 0.429378978625286, + 0.474721256740267, 0.523806740641156, 0.581962784214742, 0.652062951302463, + 0.746838578625286, 0.896492945755508, 1.0340527654686, 1.19219029825678 + ), c(0, 0, 0, 0, 0, 0.0166039560593608, 0.0776387168354182, 0.132003170161801, + 0.180530886857168, 0.22594722201882, 0.268822337600976, 0.3121244, + 0.354489864523245, 0.398378553881739, 0.444274543339083, 0.494499388431484, + 0.548837448212482, 0.612239188685087, 0.690272902609576, 0.790473599123991, + 0.950950996975469, 1.09638828065763, 1.26930966690442), c(0, + 0, 0, 0.214450885057551, 0.288864871241312, 0.3250653, 0.3516615, + 0.3716087, 0.386718885323753, 0.399682691320713, 0.411042976158862, + 0.4218461, 0.4329278, 0.444139278140181, 0.456951313505885, 0.4720835, + 0.4920307, 0.518626803531635, 0.555566110165902, 0.636745822624727, + 1.18069710590251, 1.79487371178211, 2.55270530204625), c(0, 0, 0, 0.0412188277837779, 0.218851219710947, 0.281178109847399, 0.318187061211362, 0.346336916208562, 0.368500427783778, 0.387753955899259, 0.405439627783778, 0.4218461, 0.438238911502765, 0.455473161565916, 0.474946888792488, 0.497793222697627, 0.526600327783778, 0.565677321171112, 0.632773149305243, 0.891087255237454, 1.53723873883164, 2.07877430490449, - 2.80265665435411), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0.11916637099981, 0.229217761668717, - 0.283591182792578, 0.32089403701397, 0.351025234947199, 0.376764238355684, - 0.399580647158371, 0.4218461, 0.44387311299288, 0.466809871716417, - 0.493008689720547, 0.523409488360383, 0.563157298622986, - 0.621505313473235, 0.756485815282202, 1.12190615310943, 1.76010655352564, - 2.36678033794496, 2.94420631979259), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0166944520132201, - 0.165418069472795, 0.245206977511275, 0.294705591133411, 0.333122440419504, - 0.365628706470365, 0.393898304736197, 0.4218461, 0.449111464628896, - 0.478419567119571, 0.511583967360174, 0.551380591704217, 0.602914542469175, - 0.695207681738717, 0.912006796599716, 1.31516316514125, 1.94296465866439, - 2.56528565211139, 3.07364144272118), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.095868346511765, - 0.20216012803078, 0.267545492825128, 0.314290150935209, 0.353895445422154, - 0.388115128404834, 0.4218461, 0.455823761272913, 0.49135719600286, - 0.53249009905049, 0.582341165610556, 0.654473427614026, 0.784511194125441, - 1.05644872659752, 1.47044175860169, 2.09183984013705, 2.69484857437112, - 3.1694157654766), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.189889609612846, 0.28831400446517, 0.378590156778518, - 0.474951757151471, 0.546550271666467, 0.599713541496415, - 0.636994072140471, 0.663814888730087, 0.6839305, 0.701811, - 0.71711131701917, 0.7319844, 0.746512343291783, 0.7621579, - 0.7800383, 0.800154, 0.826974702066021, 0.86472325100111, - 0.918612458720487, 0.988605006042461, 1.08324298909714, 1.1736324426019, - 1.27400190201593), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.0970521814156041, 0.21019273451422, 0.3073217, - 0.418096666577866, 0.489016664299943, 0.547102113575136, - 0.594490775323003, 0.63162246104581, 0.661579866583116, 0.687283, - 0.709633785855109, 0.7319844, 0.754030577281223, 0.776967707389074, - 0.802389, 0.832791429272493, 0.870576437517875, 0.917019363782438, - 0.973069487834329, 1.04481411391714, 1.15502640396814, 1.25613855529213, - 1.37419193312441), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.0121672025865257, 0.139873460696682, 0.245836896475015, - 0.366700877088971, 0.445024777793378, 0.506295707796278, - 0.557812941319663, 0.601634091201612, 0.639324955546405, - 0.673001603565436, 0.702827370737707, 0.7319844, 0.760387153293983, - 0.790515252114921, 0.823330663438584, 0.86065768198682, 0.904468070814958, - 0.954989716167962, 1.01626566701207, 1.09352836237872, 1.21548452077266, - 1.32239947141536, 1.46006378366371), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0.0755189873928237, - 0.192404624794198, 0.322282766861868, 0.409749729479745, 0.475729034228042, - 0.531171513462134, 0.579442333436034, 0.623023292701627, 0.662178609529395, - 0.697968947885378, 0.7319844, 0.766345465406154, 0.80256496503135, - 0.841452466611966, 0.884524366576965, 0.93218174000415, 0.988252217755677, - 1.05297410373014, 1.13838991320473, 1.27210128334768, 1.38822119412612, - 1.53603026586717), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0.0137515321313713, 0.140785106599616, 0.283710273212032, - 0.374321519596796, 0.446394180252102, 0.505830587319873, - 0.559570052916329, 0.606684360953109, 0.65111343293503, 0.692845474832798, - 0.7319844, 0.771333743893139, 0.812267094081241, 0.855930534362644, - 0.903545840608706, 0.955193592261423, 1.01560313647486, 1.08583632750787, - 1.17818451335943, 1.31856131315813, 1.44615719776698, 1.60468791291453 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, - 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, - 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.0124103998425985, 0.0518320161167612, - 0.0822283734557346, 0.106956582246572, 0.130236689538895, - 0.150852198845738, 0.168835673455735, 0.183678547429124, - 0.1975426, 0.211166273455735, 0.226249473455735, 0.243919155834858, - 0.265304527061771, 0.289781663064881, 0.315985067670677, - 0.347644682675627, 0.394981842425824, 0.491215248628636, - 0.584975102439074, 0.694697494489265), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0106056685868359, + 2.80265665435411), c(0, 0, 0, 0, 0.11916637099981, 0.229217761668717, + 0.283591182792578, 0.32089403701397, 0.351025234947199, 0.376764238355684, + 0.399580647158371, 0.4218461, 0.44387311299288, 0.466809871716417, + 0.493008689720547, 0.523409488360383, 0.563157298622986, 0.621505313473235, + 0.756485815282202, 1.12190615310943, 1.76010655352564, 2.36678033794496, + 2.94420631979259), c(0, 0, 0, 0, 0.0166944520132201, 0.165418069472795, + 0.245206977511275, 0.294705591133411, 0.333122440419504, 0.365628706470365, + 0.393898304736197, 0.4218461, 0.449111464628896, 0.478419567119571, + 0.511583967360174, 0.551380591704217, 0.602914542469175, 0.695207681738717, + 0.912006796599716, 1.31516316514125, 1.94296465866439, 2.56528565211139, + 3.07364144272118), c(0, 0, 0, 0, 0, 0.095868346511765, 0.20216012803078, + 0.267545492825128, 0.314290150935209, 0.353895445422154, 0.388115128404834, + 0.4218461, 0.455823761272913, 0.49135719600286, 0.53249009905049, + 0.582341165610556, 0.654473427614026, 0.784511194125441, 1.05644872659752, + 1.47044175860169, 2.09183984013705, 2.69484857437112, 3.1694157654766 + ), c(0.189889609612846, 0.28831400446517, 0.378590156778518, + 0.474951757151471, 0.546550271666467, 0.599713541496415, 0.636994072140471, + 0.663814888730087, 0.6839305, 0.701811, 0.71711131701917, 0.7319844, + 0.746512343291783, 0.7621579, 0.7800383, 0.800154, 0.826974702066021, + 0.86472325100111, 0.918612458720487, 0.988605006042461, 1.08324298909714, + 1.1736324426019, 1.27400190201593), c(0.0970521814156041, 0.21019273451422, + 0.3073217, 0.418096666577866, 0.489016664299943, 0.547102113575136, + 0.594490775323003, 0.63162246104581, 0.661579866583116, 0.687283, + 0.709633785855109, 0.7319844, 0.754030577281223, 0.776967707389074, + 0.802389, 0.832791429272493, 0.870576437517875, 0.917019363782438, + 0.973069487834329, 1.04481411391714, 1.15502640396814, 1.25613855529213, + 1.37419193312441), c(0.0121672025865257, 0.139873460696682, 0.245836896475015, + 0.366700877088971, 0.445024777793378, 0.506295707796278, 0.557812941319663, + 0.601634091201612, 0.639324955546405, 0.673001603565436, 0.702827370737707, + 0.7319844, 0.760387153293983, 0.790515252114921, 0.823330663438584, + 0.86065768198682, 0.904468070814958, 0.954989716167962, 1.01626566701207, + 1.09352836237872, 1.21548452077266, 1.32239947141536, 1.46006378366371 + ), c(0, 0.0755189873928237, 0.192404624794198, 0.322282766861868, + 0.409749729479745, 0.475729034228042, 0.531171513462134, 0.579442333436034, + 0.623023292701627, 0.662178609529395, 0.697968947885378, 0.7319844, + 0.766345465406154, 0.80256496503135, 0.841452466611966, 0.884524366576965, + 0.93218174000415, 0.988252217755677, 1.05297410373014, 1.13838991320473, + 1.27210128334768, 1.38822119412612, 1.53603026586717), c(0, 0.0137515321313713, + 0.140785106599616, 0.283710273212032, 0.374321519596796, 0.446394180252102, + 0.505830587319873, 0.559570052916329, 0.606684360953109, 0.65111343293503, + 0.692845474832798, 0.7319844, 0.771333743893139, 0.812267094081241, + 0.855930534362644, 0.903545840608706, 0.955193592261423, 1.01560313647486, + 1.08583632750787, 1.17818451335943, 1.31856131315813, 1.44615719776698, + 1.60468791291453), c(0, 0, 0, 0.0124103998425985, 0.0518320161167612, + 0.0822283734557346, 0.106956582246572, 0.130236689538895, 0.150852198845738, + 0.168835673455735, 0.183678547429124, 0.1975426, 0.211166273455735, + 0.226249473455735, 0.243919155834858, 0.265304527061771, 0.289781663064881, + 0.315985067670677, 0.347644682675627, 0.394981842425824, 0.491215248628636, + 0.584975102439074, 0.694697494489265), c(0, 0, 0, 0, 0.0106056685868359, 0.0491424720812208, 0.0803975947094471, 0.108060576398464, 0.133638500841809, 0.155968088623186, 0.177107275224252, 0.1975426, 0.218180906543366, 0.239601831646016, 0.262811949904799, 0.28886838404664, 0.317235975224252, 0.350545157867879, 0.393998327257523, 0.454550976564066, 0.558555075803007, - 0.656859449317743, 0.763718974419534), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.0185370189554894, + 0.656859449317743, 0.763718974419534), c(0, 0, 0, 0, 0, 0.0185370189554894, 0.0562218087603375, 0.0890356919950198, 0.118731362266373, 0.146216910144001, 0.172533896645116, 0.1975426, 0.223021121504065, 0.249412654553045, 0.277680444480195, 0.308522683806638, 0.342270845449704, 0.382702709814398, 0.433443929063141, 0.501610622734127, 0.61417580106326, 0.715138862353848, - 0.833535553075286), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0.0346528073343234, 0.0723584880324803, - 0.106222897173122, 0.138467941096611, 0.167844669490445, - 0.1975426, 0.227591504589096, 0.258479799230192, 0.290862843650987, - 0.325718759418194, 0.364163081687565, 0.409581315443156, - 0.46531554698862, 0.54043504498905, 0.659111642885379, 0.761453612496025, - 0.889794566241181), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0.0134397969692197, 0.0557212574100741, - 0.0941597345954959, 0.130401776157262, 0.164200585080601, - 0.1975426, 0.231566981332063, 0.265597088493385, 0.30192115798073, - 0.341652226704467, 0.384249568152932, 0.43541812199952, 0.495340659591346, - 0.575765691755518, 0.703032070294999, 0.815605113815338, - 0.955488202108743), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr"))), class = c("distribution", - "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, + 0.833535553075286), c(0, 0, 0, 0, 0, 0, 0.0346528073343234, 0.0723584880324803, + 0.106222897173122, 0.138467941096611, 0.167844669490445, 0.1975426, + 0.227591504589096, 0.258479799230192, 0.290862843650987, 0.325718759418194, + 0.364163081687565, 0.409581315443156, 0.46531554698862, 0.54043504498905, + 0.659111642885379, 0.761453612496025, 0.889794566241181), c(0, + 0, 0, 0, 0, 0, 0.0134397969692197, 0.0557212574100741, 0.0941597345954959, + 0.130401776157262, 0.164200585080601, 0.1975426, 0.231566981332063, + 0.265597088493385, 0.30192115798073, 0.341652226704467, 0.384249568152932, + 0.43541812199952, 0.495340659591346, 0.575765691755518, 0.703032070294999, + 0.815605113815338, 0.955488202108743)), quantile_levels = c(0.01, + 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, + 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 + ), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(19006, 19013, - 19020, 19027, 19034, 19006, 19013, 19020, 19027, 19034, 19006, + 18992, 18992), class = "Date"), target_date = structure(c(19006, 19013, 19020, 19027, 19034, 19006, 19013, 19020, 19027, 19034, 19006, 19013, 19020, 19027, 19034, 19006, 19013, 19020, 19027, - 19034), class = "Date")), row.names = c(NA, -30L), class = c("tbl_df", + 19034, 19006, 19013, 19020, 19027, 19034, 19006, 19013, 19020, + 19027, 19034), class = "Date")), row.names = c(NA, -30L), class = c("tbl_df", "tbl", "data.frame")) --- @@ -696,287 +402,180 @@ 0.7319844, 0.7319844, 0.7319844, 0.1975426, 0.1975426, 0.1975426, 0.1975426, 0.1975426), ahead = c(1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, 4L, 5L, 1L, 2L, 3L, - 4L, 5L, 1L, 2L, 3L, 4L, 5L), .pred_distn = structure(list(structure(list( - values = c(0, 0, 0.00812835000000001, 0.07297428, 0.0936219, - 0.10421786, 0.1121285, 0.1201118, 0.1273693, 0.1317238, 0.1360783, - 0.1393442, 0.1426101, 0.1469646, 0.1513191, 0.1585766, 0.1665599, - 0.17447054, 0.1850665, 0.20571412, 0.27056005, 0.313941744999999, - 0.384931126999997), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.0250982954899548, 0.0576421230361804, - 0.0776985410529105, 0.0929731777892779, 0.104205115094451, - 0.114209292598776, 0.123365027741977, 0.131496226094211, - 0.1393442, 0.147007648291083, 0.154990950042, 0.16406284204392, - 0.173835548288583, 0.185472494222942, 0.200167568392984, - 0.221760005190952, 0.260313716029161, 0.318794320716957, - 0.376941794597195, 0.461705276864399), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.028693230499105, - 0.055453963203632, 0.0755679534410344, 0.0913921813275133, 0.104804902302573, - 0.117142722458225, 0.128444430213702, 0.1393442, 0.150479535783308, - 0.161776522458225, 0.173925041831968, 0.187540579925299, 0.204200618941439, - 0.225353161205212, 0.253695961466565, 0.294498109305393, 0.358245879234942, - 0.427563795224327, 0.501665748776186), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.00587171510650109, - 0.0364866623781238, 0.0602683002957529, 0.0794861096145961, 0.0963414561651617, - 0.111439230212802, 0.125394639614746, 0.1393442, 0.153216527502025, - 0.167801944181742, 0.183359587288923, 0.200880434888349, 0.221656465706657, - 0.24743726609676, 0.279449270180852, 0.322415149384594, 0.395367499639696, - 0.464904880713406, 0.539558052669137), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0.019055042091221, - 0.0457625510440105, 0.068309473710537, 0.087945102194822, 0.106033592330923, - 0.123045226382564, 0.1393442, 0.155351600131351, 0.172491058371384, - 0.19101350900654, 0.211425349928599, 0.234936300692507, 0.264303292652126, - 0.299599722715327, 0.346282638921389, 0.423857010226352, 0.494689091614341, - 0.577833814673327), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.00138033000000002, 0.030893965, 0.0479842, - 0.059815975, 0.07118759, 0.0815075, 0.0926819, 0.0992551, - 0.103199, 0.1071429, 0.1137161, 0.1248905, 0.13521041, 0.146582025, - 0.1584138, 0.175504035, 0.20501767, 0.25694586, 0.335051815, - 0.436709474), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.0179658025100251, 0.0356060154111541, + 4L, 5L, 1L, 2L, 3L, 4L, 5L), .pred_distn = structure(list(c(0, + 0, 0.00812835000000001, 0.07297428, 0.0936219, 0.10421786, 0.1121285, + 0.1201118, 0.1273693, 0.1317238, 0.1360783, 0.1393442, 0.1426101, + 0.1469646, 0.1513191, 0.1585766, 0.1665599, 0.17447054, 0.1850665, + 0.20571412, 0.27056005, 0.313941744999999, 0.384931126999997), + c(0, 0, 0, 0.0250982954899548, 0.0576421230361804, 0.0776985410529105, + 0.0929731777892779, 0.104205115094451, 0.114209292598776, + 0.123365027741977, 0.131496226094211, 0.1393442, 0.147007648291083, + 0.154990950042, 0.16406284204392, 0.173835548288583, 0.185472494222942, + 0.200167568392984, 0.221760005190952, 0.260313716029161, + 0.318794320716957, 0.376941794597195, 0.461705276864399), + c(0, 0, 0, 0, 0.028693230499105, 0.055453963203632, 0.0755679534410344, + 0.0913921813275133, 0.104804902302573, 0.117142722458225, + 0.128444430213702, 0.1393442, 0.150479535783308, 0.161776522458225, + 0.173925041831968, 0.187540579925299, 0.204200618941439, + 0.225353161205212, 0.253695961466565, 0.294498109305393, + 0.358245879234942, 0.427563795224327, 0.501665748776186), + c(0, 0, 0, 0, 0.00587171510650109, 0.0364866623781238, 0.0602683002957529, + 0.0794861096145961, 0.0963414561651617, 0.111439230212802, + 0.125394639614746, 0.1393442, 0.153216527502025, 0.167801944181742, + 0.183359587288923, 0.200880434888349, 0.221656465706657, + 0.24743726609676, 0.279449270180852, 0.322415149384594, 0.395367499639696, + 0.464904880713406, 0.539558052669137), c(0, 0, 0, 0, 0, 0.019055042091221, + 0.0457625510440105, 0.068309473710537, 0.087945102194822, + 0.106033592330923, 0.123045226382564, 0.1393442, 0.155351600131351, + 0.172491058371384, 0.19101350900654, 0.211425349928599, 0.234936300692507, + 0.264303292652126, 0.299599722715327, 0.346282638921389, + 0.423857010226352, 0.494689091614341, 0.577833814673327), + c(0, 0, 0, 0.00138033000000002, 0.030893965, 0.0479842, 0.059815975, + 0.07118759, 0.0815075, 0.0926819, 0.0992551, 0.103199, 0.1071429, + 0.1137161, 0.1248905, 0.13521041, 0.146582025, 0.1584138, + 0.175504035, 0.20501767, 0.25694586, 0.335051815, 0.436709474 + ), c(0, 0, 0, 0, 0, 0.0179658025100251, 0.0356060154111541, 0.050834301692017, 0.0650050989327893, 0.0784417069434695, 0.0916422518458685, 0.103199, 0.115251501692017, 0.128398001692017, 0.142201701692017, 0.157319973859039, 0.174980914065641, 0.196101805086251, 0.223989860848608, 0.266334685464555, 0.354050965519204, 0.437948459272293, 0.520203978940639), - quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, - 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0, 0.0134241653129031, 0.0338447112456125, + c(0, 0, 0, 0, 0, 0, 0.0134241653129031, 0.0338447112456125, 0.052643303388484, 0.0699345638167383, 0.0866373614747148, 0.103199, 0.119627111136411, 0.137401026927169, 0.156056395793358, 0.175781901322513, 0.198564535163602, 0.226934571881819, 0.263862501322513, 0.317121769745397, 0.412419996940619, - 0.491470213131306, 0.580892509639735), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0, 0, - 0.0170903, 0.0403385023363734, 0.0616387632732329, 0.0827585779094291, - 0.103199, 0.123094939420544, 0.14464638301663, 0.1669589, 0.191770645535455, - 0.220735117412174, 0.254231042750228, 0.296807527848978, 0.357153759489695, - 0.45347931404539, 0.538725322834228, 0.636530647411066), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0, 0, 0, - 0.0026415954262542, 0.0297423239924899, 0.0555402340406406, 0.0792255827466275, - 0.103199, 0.127366925585556, 0.151700351432014, 0.177708522618176, - 0.206088123699737, 0.238712707453825, 0.277708313715037, 0.325132239647296, - 0.390468252727729, 0.490417296529864, 0.578557086846368, 0.688679948593326 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0.0320461375000001, - 0.129384955, 0.18940881, 0.2200878, 0.2427634, 0.2587698, 0.2734423, - 0.2841133, 0.296118, 0.3041212, 0.3121244, 0.3201276, 0.3281308, - 0.3401355, 0.3508065, 0.365479, 0.3814854, 0.404161, 0.43483999, - 0.494863845, 0.592202662499998, 0.737413847999994), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0.0319186440152902, - 0.118606588418984, 0.166386434627046, 0.198884154069741, 0.224089313858389, - 0.245418255377554, 0.2641052, 0.281445422925429, 0.297451875378704, - 0.3121244, 0.327667648091081, 0.343487967727477, 0.360314881408664, - 0.379575527422374, 0.400991145952209, 0.426605204088841, 0.4588495, - 0.506128350755908, 0.604640728888889, 0.713520019350718, 0.848429920658984 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0, 0, - 0, 0.0628145244703447, 0.119951261697167, 0.161800708429584, - 0.194481529786298, 0.221976473503235, 0.246382528361484, 0.268661795456855, - 0.29099237601426, 0.3121244, 0.332687273503235, 0.354487379145491, - 0.376704773503235, 0.401222379758598, 0.428725473503235, 0.462071908680987, - 0.503745448659536, 0.564825512591627, 0.677307126205362, 0.788889302835928, - 0.92389000979736), quantile_levels = c(0.01, 0.025, 0.05, 0.1, - 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, - 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.0154147362739629, 0.0815589624901754, - 0.130419447103471, 0.16933591200637, 0.202296191455315, 0.23230661698317, - 0.260103744489245, 0.28583424396924, 0.3121244, 0.337226511153312, - 0.3628113, 0.3894886, 0.419049975899859, 0.453339140405904, - 0.492830630339104, 0.542883079890499, 0.613577832767128, - 0.73571689900399, 0.853844909059791, 0.988010467319443), - quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, - 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0.0493531737111374, 0.104172112803728, - 0.147940700281253, 0.185518687303273, 0.220197034594646, - 0.2521005, 0.282477641919719, 0.3121244, 0.3414694, 0.371435390499905, - 0.402230766363414, 0.436173824348844, 0.474579164424894, - 0.519690345185252, 0.57667375206677, 0.655151246845668, 0.78520792902029, - 0.90968118047453, 1.05112182091783), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0.28439515, 0.33688581, - 0.369872555, 0.3863845, 0.3945111, 0.40189893, 0.4078092, 0.4137194, - 0.4174134, 0.4218461, 0.4262788, 0.4299728, 0.435883, 0.44179327, - 0.4491811, 0.4573077, 0.473819645, 0.50680639, 0.55929705, 0.9841905175, - 1.556671116), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, - 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, - 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0.003694, 0.268840486221162, 0.320208490155752, + 0.491470213131306, 0.580892509639735), c(0, 0, 0, 0, 0, 0, + 0, 0.0170903, 0.0403385023363734, 0.0616387632732329, 0.0827585779094291, + 0.103199, 0.123094939420544, 0.14464638301663, 0.1669589, + 0.191770645535455, 0.220735117412174, 0.254231042750228, + 0.296807527848978, 0.357153759489695, 0.45347931404539, 0.538725322834228, + 0.636530647411066), c(0, 0, 0, 0, 0, 0, 0, 0.0026415954262542, + 0.0297423239924899, 0.0555402340406406, 0.0792255827466275, + 0.103199, 0.127366925585556, 0.151700351432014, 0.177708522618176, + 0.206088123699737, 0.238712707453825, 0.277708313715037, + 0.325132239647296, 0.390468252727729, 0.490417296529864, + 0.578557086846368, 0.688679948593326), c(0, 0.0320461375000001, + 0.129384955, 0.18940881, 0.2200878, 0.2427634, 0.2587698, + 0.2734423, 0.2841133, 0.296118, 0.3041212, 0.3121244, 0.3201276, + 0.3281308, 0.3401355, 0.3508065, 0.365479, 0.3814854, 0.404161, + 0.43483999, 0.494863845, 0.592202662499998, 0.737413847999994 + ), c(0, 0, 0.0319186440152902, 0.118606588418984, 0.166386434627046, + 0.198884154069741, 0.224089313858389, 0.245418255377554, + 0.2641052, 0.281445422925429, 0.297451875378704, 0.3121244, + 0.327667648091081, 0.343487967727477, 0.360314881408664, + 0.379575527422374, 0.400991145952209, 0.426605204088841, + 0.4588495, 0.506128350755908, 0.604640728888889, 0.713520019350718, + 0.848429920658984), c(0, 0, 0, 0.0628145244703447, 0.119951261697167, + 0.161800708429584, 0.194481529786298, 0.221976473503235, + 0.246382528361484, 0.268661795456855, 0.29099237601426, 0.3121244, + 0.332687273503235, 0.354487379145491, 0.376704773503235, + 0.401222379758598, 0.428725473503235, 0.462071908680987, + 0.503745448659536, 0.564825512591627, 0.677307126205362, + 0.788889302835928, 0.92389000979736), c(0, 0, 0, 0.0154147362739629, + 0.0815589624901754, 0.130419447103471, 0.16933591200637, + 0.202296191455315, 0.23230661698317, 0.260103744489245, 0.28583424396924, + 0.3121244, 0.337226511153312, 0.3628113, 0.3894886, 0.419049975899859, + 0.453339140405904, 0.492830630339104, 0.542883079890499, + 0.613577832767128, 0.73571689900399, 0.853844909059791, 0.988010467319443 + ), c(0, 0, 0, 0, 0.0493531737111374, 0.104172112803728, 0.147940700281253, + 0.185518687303273, 0.220197034594646, 0.2521005, 0.282477641919719, + 0.3121244, 0.3414694, 0.371435390499905, 0.402230766363414, + 0.436173824348844, 0.474579164424894, 0.519690345185252, + 0.57667375206677, 0.655151246845668, 0.78520792902029, 0.90968118047453, + 1.05112182091783), c(0, 0, 0.28439515, 0.33688581, 0.369872555, + 0.3863845, 0.3945111, 0.40189893, 0.4078092, 0.4137194, 0.4174134, + 0.4218461, 0.4262788, 0.4299728, 0.435883, 0.44179327, 0.4491811, + 0.4573077, 0.473819645, 0.50680639, 0.55929705, 0.9841905175, + 1.556671116), c(0, 0, 0.003694, 0.268840486221162, 0.320208490155752, 0.34804029700677, 0.368653615349654, 0.3834292, 0.3945111, 0.4041153, 0.413171785132151, 0.4218461, 0.430424661802068, 0.4395769, 0.4491812, 0.4610017, 0.47590450199302, 0.497193409669697, 0.525275921931869, 0.57616046396334, 0.97179808113241, 1.42880557869041, - 2.00265362857685), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.0925362072632727, 0.270427502912579, + 2.00265362857685), c(0, 0, 0, 0.0925362072632727, 0.270427502912579, 0.315212102423624, 0.343335698090731, 0.364285966419164, 0.381412585636556, 0.3959887, 0.4092868, 0.4218461, 0.4344055, 0.447738051828318, 0.4632179, 0.480948870517105, 0.502553166907419, 0.531676966454865, 0.576804782629326, 0.776643061384413, - 1.21840177544959, 1.666716830807, 2.19163048441111), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, - 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, - 0.99)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.186887482630176, - 0.277238777881179, 0.317854348809488, 0.345779327332173, 0.367941987952029, - 0.38755201396574, 0.405055828677287, 0.4218461, 0.438666668060931, - 0.456611962704227, 0.476718028677287, 0.499751625882259, 0.528508989683397, - 0.569810205861059, 0.666081219804098, 0.934028445917159, 1.42658287124316, - 1.85311957889209, 2.30760254154095), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0, 0, 0.0845659921302213, - 0.228553649752897, 0.289236861333113, 0.326073140839108, 0.354785333802038, - 0.379166830409904, 0.401230227456875, 0.4218461, 0.442801275729157, - 0.465572618600986, 0.490133389090691, 0.520052318734487, 0.558588500497255, - 0.62065225601836, 0.788392143304334, 1.05428294678997, 1.55684044507063, - 2.01374350966068, 2.37954449328776), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.33818795, 0.4386877525, - 0.528816855, 0.61252005, 0.6626973, 0.6816954, 0.697340875, 0.7085162, - 0.7152214, 0.7208091, 0.72745833, 0.7319844, 0.73651047, 0.7431597, - 0.7487474, 0.7554526, 0.766627925, 0.7822734, 0.8012715, 0.85144875, - 0.935151945, 1.0252810475, 1.12578085), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.276821846502455, - 0.354318476867519, 0.440270225449805, 0.533132934163242, 0.5900576, - 0.631102729748298, 0.660462274661497, 0.680831108876989, 0.696223359635746, - 0.7096337, 0.7219265, 0.7319844, 0.7431597, 0.7543351, 0.7677455, - 0.783391, 0.804046832839828, 0.833541896886769, 0.873735298798638, - 0.929106903073231, 1.02188617627186, 1.10971107833641, 1.18626816850867 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, - 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, - 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", "dist_default", - "vctrs_rcrd", "vctrs_vctr")), structure(list(values = c(0.202265200637946, - 0.298325094034965, 0.380907645938709, 0.481339524857949, 0.543219696138311, - 0.589507953775938, 0.6258186, 0.654874580912809, 0.6783427, 0.6984583, - 0.715655544727447, 0.7319844, 0.7487473, 0.7666278, 0.785715489951649, - 0.8090941, 0.83815, 0.873623567291473, 0.920206978680437, 0.98231174201862, - 1.08425930872329, 1.16639411427812, 1.25926838507547), quantile_levels = c(0.01, + 1.21840177544959, 1.666716830807, 2.19163048441111), c(0, + 0, 0, 0, 0.186887482630176, 0.277238777881179, 0.317854348809488, + 0.345779327332173, 0.367941987952029, 0.38755201396574, 0.405055828677287, + 0.4218461, 0.438666668060931, 0.456611962704227, 0.476718028677287, + 0.499751625882259, 0.528508989683397, 0.569810205861059, + 0.666081219804098, 0.934028445917159, 1.42658287124316, 1.85311957889209, + 2.30760254154095), c(0, 0, 0, 0, 0.0845659921302213, 0.228553649752897, + 0.289236861333113, 0.326073140839108, 0.354785333802038, + 0.379166830409904, 0.401230227456875, 0.4218461, 0.442801275729157, + 0.465572618600986, 0.490133389090691, 0.520052318734487, + 0.558588500497255, 0.62065225601836, 0.788392143304334, 1.05428294678997, + 1.55684044507063, 2.01374350966068, 2.37954449328776), c(0.33818795, + 0.4386877525, 0.528816855, 0.61252005, 0.6626973, 0.6816954, + 0.697340875, 0.7085162, 0.7152214, 0.7208091, 0.72745833, + 0.7319844, 0.73651047, 0.7431597, 0.7487474, 0.7554526, 0.766627925, + 0.7822734, 0.8012715, 0.85144875, 0.935151945, 1.0252810475, + 1.12578085), c(0.276821846502455, 0.354318476867519, 0.440270225449805, + 0.533132934163242, 0.5900576, 0.631102729748298, 0.660462274661497, + 0.680831108876989, 0.696223359635746, 0.7096337, 0.7219265, + 0.7319844, 0.7431597, 0.7543351, 0.7677455, 0.783391, 0.804046832839828, + 0.833541896886769, 0.873735298798638, 0.929106903073231, + 1.02188617627186, 1.10971107833641, 1.18626816850867), c(0.202265200637946, + 0.298325094034965, 0.380907645938709, 0.481339524857949, + 0.543219696138311, 0.589507953775938, 0.6258186, 0.654874580912809, + 0.6783427, 0.6984583, 0.715655544727447, 0.7319844, 0.7487473, + 0.7666278, 0.785715489951649, 0.8090941, 0.83815, 0.873623567291473, + 0.920206978680437, 0.98231174201862, 1.08425930872329, 1.16639411427812, + 1.25926838507547), c(0.129193504425124, 0.241744300793533, + 0.331949483165032, 0.43649858695157, 0.504472062268773, 0.556141464729147, + 0.597172505336053, 0.631406591640416, 0.660898437441874, + 0.686684727470375, 0.709633972330423, 0.7319844, 0.753217699696647, + 0.77608746100351, 0.8012715950276, 0.830327492252422, 0.86464477397774, + 0.906319686121761, 0.956815387818928, 1.02495125855129, 1.13129413647201, + 1.21644533535035, 1.32424172966634), c(0.0667682979050189, + 0.189580042212397, 0.290485041721667, 0.402951609190092, + 0.475328740486855, 0.530590906520765, 0.575504908587586, + 0.613421932920829, 0.647285177364573, 0.678099283398734, + 0.70593862799773, 0.7319844, 0.758701322488325, 0.786639532920829, + 0.816837200234752, 0.850627936753767, 0.888963924063491, + 0.933785069065791, 0.988913131611816, 1.06240172852619, 1.16959624730917, + 1.2662008825538, 1.38860505690239), c(0, 0, 0.0419413650000001, + 0.09882005, 0.1230992, 0.14226962, 0.1600776, 0.1722416, + 0.1800265, 0.1880061, 0.1936501, 0.1975426, 0.2014351, 0.2070791, + 0.2150587, 0.2228436, 0.2350076, 0.25281558, 0.271986, 0.29626515, + 0.353143835, 0.4353357125, 0.545314878), c(0, 0, 0, 0.0438463650372504, + 0.0808594787511875, 0.106995615813358, 0.127478232938079, + 0.145480846633466, 0.1610508, 0.17461199504795, 0.186668812203222, + 0.1975426, 0.208428571374764, 0.2204108, 0.233930283744537, + 0.249894552784127, 0.267362348440485, 0.288755575723157, + 0.316120297580926, 0.355450425419354, 0.443192503687136, + 0.536871211931719, 0.636344785545224), c(0, 0, 0, 0.00188932708477086, + 0.0470905919531195, 0.079226864399944, 0.105414109111591, + 0.127225815559956, 0.146699420891509, 0.164644114298843, + 0.18142942603581, 0.1975426, 0.213933119201142, 0.231001630488804, + 0.24941229702312, 0.269578845560456, 0.292362546530965, 0.319632071367214, + 0.354433951358713, 0.406915236639266, 0.506944745332152, + 0.596044605353528, 0.695533388807317), c(0, 0, 0, 0, 0.0156342454546545, + 0.0536811248488485, 0.084228833507335, 0.110407751354614, + 0.134410113872139, 0.156669167575476, 0.177701902429674, + 0.1975426, 0.217759024165492, 0.238897316673167, 0.261484572608426, + 0.286120039498095, 0.313065324705997, 0.345395334882349, + 0.386811116673167, 0.44780805303823, 0.550781846423163, 0.644984940689833, + 0.752937731654986), c(0, 0, 0, 0, 0, 0.0290260214229144, + 0.0653218111708617, 0.0966336637233373, 0.124670861123061, + 0.149775978614687, 0.174275935467055, 0.1975426, 0.221291415429954, + 0.246723385601356, 0.273144383515685, 0.30101566402084, 0.33204051788793, + 0.369730347126771, 0.416909038104281, 0.481925596660567, + 0.58989871202142, 0.688635568252056, 0.803906183401304)), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.129193504425124, - 0.241744300793533, 0.331949483165032, 0.43649858695157, 0.504472062268773, - 0.556141464729147, 0.597172505336053, 0.631406591640416, 0.660898437441874, - 0.686684727470375, 0.709633972330423, 0.7319844, 0.753217699696647, - 0.77608746100351, 0.8012715950276, 0.830327492252422, 0.86464477397774, - 0.906319686121761, 0.956815387818928, 1.02495125855129, 1.13129413647201, - 1.21644533535035, 1.32424172966634), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.0667682979050189, - 0.189580042212397, 0.290485041721667, 0.402951609190092, 0.475328740486855, - 0.530590906520765, 0.575504908587586, 0.613421932920829, 0.647285177364573, - 0.678099283398734, 0.70593862799773, 0.7319844, 0.758701322488325, - 0.786639532920829, 0.816837200234752, 0.850627936753767, 0.888963924063491, - 0.933785069065791, 0.988913131611816, 1.06240172852619, 1.16959624730917, - 1.2662008825538, 1.38860505690239), quantile_levels = c(0.01, - 0.025, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, - 0.55, 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99 - )), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0, 0, 0.0419413650000001, - 0.09882005, 0.1230992, 0.14226962, 0.1600776, 0.1722416, 0.1800265, - 0.1880061, 0.1936501, 0.1975426, 0.2014351, 0.2070791, 0.2150587, - 0.2228436, 0.2350076, 0.25281558, 0.271986, 0.29626515, 0.353143835, - 0.4353357125, 0.545314878), quantile_levels = c(0.01, 0.025, - 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, - 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.0438463650372504, 0.0808594787511875, - 0.106995615813358, 0.127478232938079, 0.145480846633466, - 0.1610508, 0.17461199504795, 0.186668812203222, 0.1975426, - 0.208428571374764, 0.2204108, 0.233930283744537, 0.249894552784127, - 0.267362348440485, 0.288755575723157, 0.316120297580926, - 0.355450425419354, 0.443192503687136, 0.536871211931719, - 0.636344785545224), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0.00188932708477086, 0.0470905919531195, - 0.079226864399944, 0.105414109111591, 0.127225815559956, - 0.146699420891509, 0.164644114298843, 0.18142942603581, 0.1975426, - 0.213933119201142, 0.231001630488804, 0.24941229702312, 0.269578845560456, - 0.292362546530965, 0.319632071367214, 0.354433951358713, - 0.406915236639266, 0.506944745332152, 0.596044605353528, - 0.695533388807317), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0.0156342454546545, 0.0536811248488485, - 0.084228833507335, 0.110407751354614, 0.134410113872139, - 0.156669167575476, 0.177701902429674, 0.1975426, 0.217759024165492, - 0.238897316673167, 0.261484572608426, 0.286120039498095, - 0.313065324705997, 0.345395334882349, 0.386811116673167, - 0.44780805303823, 0.550781846423163, 0.644984940689833, 0.752937731654986 - ), quantile_levels = c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, - 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, 0.65, 0.7, 0.75, - 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0, 0, 0, 0, 0, 0.0290260214229144, 0.0653218111708617, - 0.0966336637233373, 0.124670861123061, 0.149775978614687, - 0.174275935467055, 0.1975426, 0.221291415429954, 0.246723385601356, - 0.273144383515685, 0.30101566402084, 0.33204051788793, 0.369730347126771, - 0.416909038104281, 0.481925596660567, 0.58989871202142, 0.688635568252056, - 0.803906183401304), quantile_levels = c(0.01, 0.025, 0.05, - 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, 0.6, - 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 0.95, 0.975, 0.99)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr"))), class = c("distribution", - "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, + ), class = c("quantile_pred", "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, 18992, - 18992), class = "Date"), target_date = structure(c(18997, 19002, - 19007, 19012, 19017, 18997, 19002, 19007, 19012, 19017, 18997, + 18992, 18992), class = "Date"), target_date = structure(c(18997, 19002, 19007, 19012, 19017, 18997, 19002, 19007, 19012, 19017, 18997, 19002, 19007, 19012, 19017, 18997, 19002, 19007, 19012, - 19017), class = "Date")), row.names = c(NA, -30L), class = c("tbl_df", + 19017, 18997, 19002, 19007, 19012, 19017, 18997, 19002, 19007, + 19012, 19017), class = "Date")), row.names = c(NA, -30L), class = c("tbl_df", "tbl", "data.frame")) # arx_forecaster snapshots @@ -984,24 +583,13 @@ structure(list(geo_value = c("ca", "fl", "ga", "ny", "pa", "tx" ), .pred = c(0.353013358779435, 0.648525432444877, 0.667670289394328, 1.1418673907239, 0.830448695683587, 0.329799431948649), .pred_distn = structure(list( - structure(list(values = c(0.171022956902288, 0.535003760656582 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.46653503056773, 0.830515834322024), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.485679887517181, - 0.849660691271475), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.959876988846753, 1.32385779260105), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.64845829380644, - 1.01243909756073), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.147809030071502, 0.511789833825796), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr"))), class = c("distribution", "vctrs_vctr", - "list")), forecast_date = structure(c(18992, 18992, 18992, 18992, - 18992, 18992), class = "Date"), target_date = structure(c(18999, + c(0.171022956902288, 0.535003760656582), c(0.46653503056773, + 0.830515834322024), c(0.485679887517181, 0.849660691271475 + ), c(0.959876988846753, 1.32385779260105), c(0.64845829380644, + 1.01243909756073), c(0.147809030071502, 0.511789833825796 + )), quantile_levels = c(0.05, 0.95), class = c("quantile_pred", + "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, + 18992, 18992, 18992, 18992), class = "Date"), target_date = structure(c(18999, 18999, 18999, 18999, 18999, 18999), class = "Date")), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame")) @@ -1010,24 +598,13 @@ structure(list(geo_value = c("ca", "fl", "ga", "ny", "pa", "tx" ), .pred = c(0.149303403634373, 0.139764664505948, 0.333186321066645, 0.470345577837144, 0.725986105412008, 0.212686665274007), .pred_distn = structure(list( - structure(list(values = c(0.0961118191398634, 0.202494988128882 - ), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.0865730800114383, 0.192956249000457), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.279994736572136, - 0.386377905561154), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.417153993342634, 0.523537162331653), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr")), structure(list(values = c(0.672794520917498, - 0.779177689906517), quantile_levels = c(0.05, 0.95)), class = c("dist_quantiles", - "dist_default", "vctrs_rcrd", "vctrs_vctr")), structure(list( - values = c(0.159495080779498, 0.265878249768516), quantile_levels = c(0.05, - 0.95)), class = c("dist_quantiles", "dist_default", "vctrs_rcrd", - "vctrs_vctr"))), class = c("distribution", "vctrs_vctr", - "list")), forecast_date = structure(c(18992, 18992, 18992, 18992, - 18992, 18992), class = "Date"), target_date = structure(c(18993, + c(0.0961118191398634, 0.202494988128882), c(0.0865730800114383, + 0.192956249000457), c(0.279994736572136, 0.386377905561154 + ), c(0.417153993342634, 0.523537162331653), c(0.672794520917498, + 0.779177689906517), c(0.159495080779498, 0.265878249768516 + )), quantile_levels = c(0.05, 0.95), class = c("quantile_pred", + "vctrs_vctr", "list")), forecast_date = structure(c(18992, 18992, + 18992, 18992, 18992, 18992), class = "Date"), target_date = structure(c(18993, 18993, 18993, 18993, 18993, 18993), class = "Date")), row.names = c(NA, -6L), class = c("tbl_df", "tbl", "data.frame")) diff --git a/tests/testthat/_snaps/step_epi_shift.md b/tests/testthat/_snaps/step_epi_shift.md index 44c828118..1c14bd68e 100644 --- a/tests/testthat/_snaps/step_epi_shift.md +++ b/tests/testthat/_snaps/step_epi_shift.md @@ -1,8 +1,8 @@ # 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) + r1 <- 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. @@ -10,7 +10,7 @@ # A negative lag value should should throw an error Code - r2 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = 7) %>% step_epi_lag( + r2 <- recipe(x) %>% step_epi_ahead(death_rate, ahead = 7) %>% step_epi_lag( death_rate, lag = -7) Condition Error in `step_epi_lag()`: @@ -19,7 +19,7 @@ # A nonpositive ahead value should throw an error Code - r3 <- epi_recipe(x) %>% step_epi_ahead(death_rate, ahead = -7) %>% step_epi_lag( + r3 <- recipe(x) %>% step_epi_ahead(death_rate, ahead = -7) %>% step_epi_lag( death_rate, lag = 7) Condition Error in `step_epi_ahead()`: @@ -30,7 +30,8 @@ Code slm_fit(r4) Condition - Error in `bake()`: + Error in `step_epi_lag()`: + Caused by 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 index a4b9d64c8..e1fbd6bc6 100644 --- a/tests/testthat/_snaps/step_epi_slide.md +++ b/tests/testthat/_snaps/step_epi_slide.md @@ -2,9 +2,18 @@ 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 . + Message + + -- Epi Recipe ------------------------------------------------------------------ + + -- Inputs + Number of variables by role + geo_value: 1 + time_value: 1 + undeclared role: 1 + + -- Operations + 1. Calculating epi_slide for: value with .f --- diff --git a/tests/testthat/_snaps/wis-dist-quantiles.md b/tests/testthat/_snaps/wis-dist-quantiles.md deleted file mode 100644 index fb9cfbdf6..000000000 --- a/tests/testthat/_snaps/wis-dist-quantiles.md +++ /dev/null @@ -1,17 +0,0 @@ -# wis dispatches and produces the correct values - - Code - weighted_interval_score(1:10, 10) - Condition - Error in `weighted_interval_score()`: - ! Weighted interval score can only be calculated if `x` - has class . - ---- - - Code - weighted_interval_score(dist_quantiles(list(1:4, 8:11), 1:4 / 5), 1:3) - Condition - Error in `weighted_interval_score()`: - ! Can't recycle `x` (size 2) to match `actual` (size 3). - diff --git a/tests/testthat/test-arg_is_.R b/tests/testthat/test-arg_is_.R index 89c2c936f..b4d5f1a4c 100644 --- a/tests/testthat/test-arg_is_.R +++ b/tests/testthat/test-arg_is_.R @@ -149,6 +149,6 @@ test_that("coerce scalar to date", { test_that("simple surface step test", { expect_snapshot( error = TRUE, - epi_recipe(jhu_csse_daily_subset) %>% step_epi_lag(death_rate, lag = "hello") + recipe(jhu_csse_daily_subset) %>% step_epi_lag(death_rate, lag = "hello") ) }) diff --git a/tests/testthat/test-check_enough_train_data.R b/tests/testthat/test-check_enough_train_data.R index 320475492..446dc321e 100644 --- a/tests/testthat/test-check_enough_train_data.R +++ b/tests/testthat/test-check_enough_train_data.R @@ -25,7 +25,7 @@ test_that("check_enough_train_data works on pooled data", { # Check both column don't have enough data expect_snapshot( error = TRUE, - epi_recipe(toy_epi_df) %>% + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n + 1, drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) @@ -33,7 +33,7 @@ test_that("check_enough_train_data works on pooled data", { # Check drop_na works expect_snapshot( error = TRUE, - epi_recipe(toy_epi_df) %>% + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 1, drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) @@ -51,7 +51,7 @@ test_that("check_enough_train_data works on unpooled data", { # Check one column don't have enough data expect_snapshot( error = TRUE, - epi_recipe(toy_epi_df) %>% + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = n + 1, epi_keys = "geo_value", drop_na = FALSE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) @@ -59,7 +59,7 @@ test_that("check_enough_train_data works on unpooled data", { # Check drop_na works expect_snapshot( error = TRUE, - epi_recipe(toy_epi_df) %>% + recipe(toy_epi_df) %>% check_enough_train_data(x, y, n = 2 * n - 3, epi_keys = "geo_value", drop_na = TRUE) %>% prep(toy_epi_df) %>% bake(new_data = NULL) @@ -118,7 +118,7 @@ test_that("check_enough_train_data works with all_predictors() downstream of con ) expect_snapshot( error = TRUE, - epi_recipe(toy_epi_df) %>% + recipe(toy_epi_df) %>% step_epi_lag(x, lag = c(1, 2)) %>% check_enough_train_data(all_predictors(), y, n = 2 * n - 5) %>% prep(toy_epi_df) %>% diff --git a/tests/testthat/test-epi_workflow.R b/tests/testthat/test-epi_workflow.R index dfcb67f3a..9a87745ed 100644 --- a/tests/testthat/test-epi_workflow.R +++ b/tests/testthat/test-epi_workflow.R @@ -120,8 +120,7 @@ test_that("fit method does not silently drop the class", { rec_tbl <- recipe(y ~ x, data = tbl) rec_edf <- recipe(y ~ x, data = edf) - expect_snapshot(error = TRUE, epi_recipe(y ~ x, data = tbl)) - erec_edf <- epi_recipe(y ~ x, data = edf) + erec_edf <- recipe(y ~ x, data = edf) ewf_rec_tbl <- epi_workflow(rec_tbl, linear_reg()) ewf_rec_edf <- epi_workflow(rec_edf, linear_reg()) @@ -137,8 +136,8 @@ test_that("fit method does not silently drop the class", { expect_s3_class(ewf_rec_tbl %>% fit(tbl), "epi_workflow") expect_s3_class(ewf_rec_tbl %>% fit(edf), "epi_workflow") - expect_s3_class(ewf_rec_edf %>% fit(tbl), "epi_workflow") + expect_warning(ewf_rec_edf %>% fit(tbl)) expect_s3_class(ewf_rec_edf %>% fit(edf), "epi_workflow") - expect_snapshot(ewf_erec_edf %>% fit(tbl), error = TRUE) + expect_warning(ewf_erec_edf %>% fit(tbl)) expect_s3_class(ewf_erec_edf %>% fit(edf), "epi_workflow") }) diff --git a/tests/testthat/test-key_colnames.R b/tests/testthat/test-key_colnames.R index 9ece36ed3..cbf8e3a75 100644 --- a/tests/testthat/test-key_colnames.R +++ b/tests/testthat/test-key_colnames.R @@ -46,7 +46,7 @@ test_that("key_colnames extracts additional keys when they are present", { c("geo_value", "state", "pol", "time_value") ) - my_recipe <- epi_recipe(my_data) %>% + my_recipe <- recipe(my_data) %>% step_epi_ahead(value, ahead = 7) %>% step_epi_naomit() diff --git a/tests/testthat/test-population_scaling.R b/tests/testthat/test-population_scaling.R index b05c504d4..b2b7c1bd6 100644 --- a/tests/testthat/test-population_scaling.R +++ b/tests/testthat/test-population_scaling.R @@ -51,7 +51,7 @@ test_that("Number of columns and column names returned correctly, Upper and lowe case = 1:10, death = 1:10 ) %>% - epiprocess::as_epi_df(additional_metadata = list(other_keys = "county")) + epiprocess::as_epi_df(other_keys = "county") r <- recipe(newdata) %>% step_population_scaling(c("case", "death"), diff --git a/tests/testthat/test-step_epi_shift.R b/tests/testthat/test-step_epi_shift.R index c333fd514..1da61a402 100644 --- a/tests/testthat/test-step_epi_shift.R +++ b/tests/testthat/test-step_epi_shift.R @@ -22,7 +22,7 @@ slm_fit <- function(recipe, data = x) { test_that("Values for ahead and lag must be integer values", { expect_snapshot( error = TRUE, - r1 <- epi_recipe(x) %>% + r1 <- recipe(x) %>% step_epi_ahead(death_rate, ahead = 3.6) %>% step_epi_lag(death_rate, lag = 1.9) ) @@ -31,7 +31,7 @@ test_that("Values for ahead and lag must be integer values", { test_that("A negative lag value should should throw an error", { expect_snapshot( error = TRUE, - r2 <- epi_recipe(x) %>% + r2 <- recipe(x) %>% step_epi_ahead(death_rate, ahead = 7) %>% step_epi_lag(death_rate, lag = -7) ) @@ -40,7 +40,7 @@ test_that("A negative lag value should should throw an error", { test_that("A nonpositive ahead value should throw an error", { expect_snapshot( error = TRUE, - r3 <- epi_recipe(x) %>% + r3 <- recipe(x) %>% step_epi_ahead(death_rate, ahead = -7) %>% step_epi_lag(death_rate, lag = 7) ) diff --git a/tests/testthat/test-step_epi_slide.R b/tests/testthat/test-step_epi_slide.R index 27f362ad6..5bbafc93e 100644 --- a/tests/testthat/test-step_epi_slide.R +++ b/tests/testthat/test-step_epi_slide.R @@ -7,12 +7,12 @@ edf <- data.frame( value = c(2:21, 3:22) ) %>% as_epi_df() -r <- epi_recipe(edf) +r <- recipe(edf) test_that("epi_slide errors when needed", { # not an epi_recipe - expect_snapshot(error = TRUE, recipe(edf) %>% step_epi_slide(value, .f = mean, .window_size = 7L)) + expect_snapshot(recipe(edf) %>% step_epi_slide(value, .f = mean, .window_size = 7L)) # non-scalar args expect_snapshot(error = TRUE, r %>% step_epi_slide(value, .f = mean, .window_size = c(3L, 6L))) diff --git a/tests/testthat/test-step_training_window.R b/tests/testthat/test-step_training_window.R index 366e90c8e..d8675fdc5 100644 --- a/tests/testthat/test-step_training_window.R +++ b/tests/testthat/test-step_training_window.R @@ -73,7 +73,7 @@ test_that("step_training_window works with multiple keys", { geo_value = rep(c("ca", "hi"), each = 100), additional_key = as.factor(rep(1:4, each = 50)), ) %>% - epiprocess::as_epi_df(additional_metadata = list(other_keys = "additional_key")) + epiprocess::as_epi_df(other_keys = "additional_key") p4 <- recipe(y ~ x, data = toy_epi_df2) %>% step_training_window(n_recent = 3) %>% From 3d58952fb1f810453e7a337ca77ebd7f03c2b1d5 Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Tue, 1 Oct 2024 17:47:52 -0700 Subject: [PATCH 36/37] tests/checks pass. done. --- DESCRIPTION | 1 - NAMESPACE | 2 ++ R/extrapolate_quantiles.R | 4 ++-- R/quantile_pred-methods.R | 5 ++++- R/reexports-tidymodels.R | 5 +++++ man/extrapolate_quantiles.Rd | 4 ++-- man/reexports.Rd | 9 +++++++-- vignettes/epipredict.Rmd | 9 ++++----- 8 files changed, 26 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 16b2f7b5c..8dfffaa87 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,7 +36,6 @@ Imports: ggplot2, glue, hardhat (>= 1.4.0.9002), - hardhat (>= 1.3.0), lifecycle, magrittr, recipes (>= 1.0.4), diff --git a/NAMESPACE b/NAMESPACE index 9762a1696..9ba791bec 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -132,6 +132,7 @@ export(arx_class_epi_workflow) export(arx_classifier) export(arx_fcast_epi_workflow) export(arx_forecaster) +export(as_tibble) export(autoplot) export(bake) export(cdc_baseline_args_list) @@ -173,6 +174,7 @@ export(layer_unnest) export(pivot_quantiles_longer) export(pivot_quantiles_wider) export(prep) +export(quantile_pred) export(quantile_reg) export(rand_id) export(recipe) diff --git a/R/extrapolate_quantiles.R b/R/extrapolate_quantiles.R index 82116c1d3..c7a9a3b6b 100644 --- a/R/extrapolate_quantiles.R +++ b/R/extrapolate_quantiles.R @@ -18,9 +18,9 @@ #' @export #' #' @examples -#' dstn <- quantile_dstn(rbind(1:4, 8:11), c(.2, .4, .6, .8)) +#' dstn <- quantile_pred(rbind(1:4, 8:11), c(.2, .4, .6, .8)) #' # extra quantiles are appended -#' as.tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))) +#' as_tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))) extrapolate_quantiles <- function(x, probs, replace_na = TRUE, ...) { UseMethod("extrapolate_quantiles") } diff --git a/R/quantile_pred-methods.R b/R/quantile_pred-methods.R index 1f86052d1..768bbd65e 100644 --- a/R/quantile_pred-methods.R +++ b/R/quantile_pred-methods.R @@ -1,6 +1,9 @@ +#' @importFrom hardhat quantile_pred +#' @export +hardhat::quantile_pred + # placeholder to avoid errors, but not ideal -#' @importFrom hardhat quantile_pred #' @export mean.quantile_pred <- function(x, na.rm = FALSE, ...) { median(x, ...) diff --git a/R/reexports-tidymodels.R b/R/reexports-tidymodels.R index 5b53914a8..2c87878ea 100644 --- a/R/reexports-tidymodels.R +++ b/R/reexports-tidymodels.R @@ -27,6 +27,11 @@ recipes::rand_id #' @export tibble::tibble +#' @importFrom tibble as_tibble +#' @export +tibble::as_tibble + + #' @importFrom generics tidy #' @export generics::tidy diff --git a/man/extrapolate_quantiles.Rd b/man/extrapolate_quantiles.Rd index b645b85fa..bd460dbe9 100644 --- a/man/extrapolate_quantiles.Rd +++ b/man/extrapolate_quantiles.Rd @@ -29,7 +29,7 @@ similar to \code{\link[stats:quantile]{stats::quantile()}}, then \code{quantile( appropriate. } \examples{ -dstn <- quantile_dstn(rbind(1:4, 8:11), c(.2, .4, .6, .8)) +dstn <- quantile_pred(rbind(1:4, 8:11), c(.2, .4, .6, .8)) # extra quantiles are appended -as.tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))) +as_tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))) } diff --git a/man/reexports.Rd b/man/reexports.Rd index 6006555b9..910ca9b5d 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -1,9 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autoplot.R, R/reexports-tidymodels.R +% Please edit documentation in R/autoplot.R, R/quantile_pred-methods.R, +% R/reexports-tidymodels.R \docType{import} \name{reexports} \alias{reexports} \alias{autoplot} +\alias{quantile_pred} \alias{fit} \alias{forecast} \alias{prep} @@ -11,6 +13,7 @@ \alias{recipe} \alias{rand_id} \alias{tibble} +\alias{as_tibble} \alias{tidy} \title{Objects exported from other packages} \keyword{internal} @@ -23,8 +26,10 @@ below to see their documentation. \item{ggplot2}{\code{\link[ggplot2]{autoplot}}} + \item{hardhat}{\code{\link[hardhat]{quantile_pred}}} + \item{recipes}{\code{\link[recipes]{bake}}, \code{\link[recipes]{prep}}, \code{\link[recipes]{rand_id}}, \code{\link[recipes]{recipe}}} - \item{tibble}{\code{\link[tibble]{tibble}}} + \item{tibble}{\code{\link[tibble]{as_tibble}}, \code{\link[tibble]{tibble}}} }} diff --git a/vignettes/epipredict.Rmd b/vignettes/epipredict.Rmd index f172e4e48..8c6a02aef 100644 --- a/vignettes/epipredict.Rmd +++ b/vignettes/epipredict.Rmd @@ -229,14 +229,13 @@ quantile, head(quantile(out_q$predictions$.pred_distn, p = .4)) ``` -or extract the entire distribution into a "long" `epi_df` with `quantile_levels` -being the probability and `values` being the value associated to that quantile. +or extract the entire distribution into a "long" `epi_df` with `quantile_level` +being the probability and `value` being the value associated to that quantile +(each prefixed with the original column name `.pred_distn`). ```{r q2} out_q$predictions %>% - # first create a "nested" list-column - mutate(.pred_distn = nested_quantiles(.pred_distn)) %>% - unnest(.pred_distn) # then unnest it + pivot_quantiles_longer(.pred_distn) ``` Additional simple adjustments to the basic forecaster can be made using the From ed88db6f2b303a6c6b4932675086178b12c3f89e Mon Sep 17 00:00:00 2001 From: "Daniel J. McDonald" Date: Mon, 21 Oct 2024 14:03:09 -0700 Subject: [PATCH 37/37] needs dev hardhat --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8dfffaa87..fc75f091f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -70,7 +70,8 @@ VignetteBuilder: Remotes: cmu-delphi/epidatr, cmu-delphi/epiprocess, - dajmcdon/smoothqr + dajmcdon/smoothqr, + tidymodels/hardhat Config/testthat/edition: 3 Encoding: UTF-8 LazyData: true