diff --git a/DESCRIPTION b/DESCRIPTION index f880d825..f6f1c347 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: epiprocess Title: Tools for basic signal processing in epidemiology -Version: 0.9.1 +Version: 0.9.3 Authors@R: c( person("Jacob", "Bien", role = "ctb"), person("Logan", "Brooks", , "lcbrooks@andrew.cmu.edu", role = c("aut", "cre")), diff --git a/NEWS.md b/NEWS.md index ee04b7f3..dd562c9b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,21 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.x.y will indicate PR's. +# epiprocess 0.10 + +## Breaking changes + +- Removed `.window_size = 1` default from `epi_slide_{mean,sum,opt}`; this + argument is now mandatory, and should nearly always be greater than 1 except + for testing purposes. + +## Improvements + +- `epi_slide` and `epix_slide` now provide some hints if you forget a `~` when + using a formula to specify the slide computation, and other bits of forgotten + syntax. +- Improved validation of `.window_size` arguments. + # epiprocess 0.9 ## Breaking changes diff --git a/R/grouped_epi_archive.R b/R/grouped_epi_archive.R index b592cd91..bec8c9c2 100644 --- a/R/grouped_epi_archive.R +++ b/R/grouped_epi_archive.R @@ -312,14 +312,15 @@ epix_slide.grouped_epi_archive <- function( cli_abort("If `f` is missing then a computation must be specified via `...`.") } - .slide_comp <- as_diagonal_slide_computation(quosures) + .f_arg <- ".f" # dummy val, shouldn't be used since we're not using `.f` + .slide_comp <- as_diagonal_slide_computation(quosures, .f_arg = .f_arg) # Magic value that passes zero args as dots in calls below. Equivalent to # `... <- missing_arg()`, but use `assign` to avoid warning about # improper use of dots. assign("...", missing_arg()) } else { used_data_masking <- FALSE - .slide_comp <- as_diagonal_slide_computation(.f, ...) + .slide_comp <- as_diagonal_slide_computation(.f, ..., .f_arg = caller_arg(.f)) } # Computation for one group, one time value diff --git a/R/slide.R b/R/slide.R index 5a7fbd6a..5df474b2 100644 --- a/R/slide.R +++ b/R/slide.R @@ -147,14 +147,16 @@ epi_slide <- function( } .f <- quosures + .f_arg <- ".f" # dummy val, shouldn't be used since we're not using `.f` # Magic value that passes zero args as dots in calls below. Equivalent to # `... <- missing_arg()`, but `assign` avoids warning about improper use of # dots. assign("...", missing_arg()) } else { used_data_masking <- FALSE + .f_arg <- caller_arg(.f) } - .slide_comp <- as_time_slide_computation(.f, ...) + .slide_comp <- as_time_slide_computation(.f, ..., .f_arg = .f_arg) .align <- rlang::arg_match(.align) time_type <- attr(.x, "metadata")$time_type @@ -576,7 +578,7 @@ get_before_after_from_window <- function(window_size, align, time_type) { #' ungroup() epi_slide_opt <- function( .x, .col_names, .f, ..., - .window_size = 1, .align = c("right", "center", "left"), + .window_size = NULL, .align = c("right", "center", "left"), .ref_time_values = NULL, .all_rows = FALSE) { assert_class(.x, "epi_df") @@ -678,46 +680,16 @@ epi_slide_opt <- function( ref_time_values <- sort(.ref_time_values) # Handle window arguments - align <- rlang::arg_match(.align) + .align <- rlang::arg_match(.align) time_type <- attr(.x, "metadata")$time_type - validate_slide_window_arg(.window_size, time_type) - if (identical(.window_size, Inf)) { - if (align == "right") { - before <- Inf - if (time_type %in% c("day", "week")) { - after <- as.difftime(0, units = glue::glue("{time_type}s")) - } else { - after <- 0 - } - } else { - cli_abort( - "`epi_slide`: center and left alignment are not supported with an infinite window size." - ) - } - } else { - if (align == "right") { - before <- .window_size - 1 - if (time_type %in% c("day", "week")) { - after <- as.difftime(0, units = glue::glue("{time_type}s")) - } else { - after <- 0 - } - } else if (align == "center") { - # For .window_size = 5, before = 2, after = 2. For .window_size = 4, before = 2, after = 1. - before <- floor(.window_size / 2) - after <- .window_size - before - 1 - } else if (align == "left") { - if (time_type %in% c("day", "week")) { - before <- as.difftime(0, units = glue::glue("{time_type}s")) - } else { - before <- 0 - } - after <- .window_size - 1 - } + if (is.null(.window_size)) { + cli_abort("epi_slide_opt: `.window_size` must be specified.") } + validate_slide_window_arg(.window_size, time_type) + window_args <- get_before_after_from_window(.window_size, .align, time_type) # Make a complete date sequence between min(.x$time_value) and max(.x$time_value). - date_seq_list <- full_date_seq(.x, before, after, time_type) + date_seq_list <- full_date_seq(.x, window_args$before, window_args$after, time_type) all_dates <- date_seq_list$all_dates pad_early_dates <- date_seq_list$pad_early_dates pad_late_dates <- date_seq_list$pad_late_dates @@ -786,16 +758,16 @@ epi_slide_opt <- function( # `before` and `after` params. Right-aligned `frollmean` results' # `ref_time_value`s will be `after` timesteps ahead of where they should # be; shift results to the left by `after` timesteps. - if (before != Inf) { - window_size <- before + after + 1L + if (window_args$before != Inf) { + window_size <- window_args$before + window_args$after + 1L roll_output <- .f(x = .data_group[, col_names_chr], n = window_size, ...) } else { window_size <- list(seq_along(.data_group$time_value)) roll_output <- .f(x = .data_group[, col_names_chr], n = window_size, adaptive = TRUE, ...) } - if (after >= 1) { + if (window_args$after >= 1) { .data_group[, result_col_names] <- purrr::map(roll_output, function(.x) { - c(.x[(after + 1L):length(.x)], rep(NA, after)) + c(.x[(window_args$after + 1L):length(.x)], rep(NA, window_args$after)) }) } else { .data_group[, result_col_names] <- roll_output @@ -805,8 +777,8 @@ epi_slide_opt <- function( for (i in seq_along(col_names_chr)) { .data_group[, result_col_names[i]] <- .f( x = .data_group[[col_names_chr[i]]], - before = as.numeric(before), - after = as.numeric(after), + before = as.numeric(window_args$before), + after = as.numeric(window_args$after), ... ) } @@ -902,7 +874,7 @@ epi_slide_opt <- function( #' ungroup() epi_slide_mean <- function( .x, .col_names, ..., - .window_size = 1, .align = c("right", "center", "left"), + .window_size = NULL, .align = c("right", "center", "left"), .ref_time_values = NULL, .all_rows = FALSE) { # Deprecated argument handling provided_args <- rlang::call_args_names(rlang::call_match()) @@ -979,7 +951,7 @@ epi_slide_mean <- function( #' ungroup() epi_slide_sum <- function( .x, .col_names, ..., - .window_size = 1, .align = c("right", "center", "left"), + .window_size = NULL, .align = c("right", "center", "left"), .ref_time_values = NULL, .all_rows = FALSE) { # Deprecated argument handling provided_args <- rlang::call_args_names(rlang::call_match()) diff --git a/R/utils.R b/R/utils.R index bb30264a..066b374e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -358,9 +358,48 @@ assert_sufficient_f_args <- function(.f, ..., .ref_time_value_label) { #' @importFrom rlang is_function new_function f_env is_environment missing_arg #' f_rhs is_formula caller_arg caller_env #' @keywords internal -as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_time_value_label) { - arg <- caller_arg(.f) - call <- caller_env() +as_slide_computation <- function(.f, ..., + .f_arg = caller_arg(.f), .call = caller_env(), + .ref_time_value_long_varnames, .ref_time_value_label) { + if (".col_names" %in% rlang::call_args_names(rlang::call_match())) { + cli_abort( + c("{.code epi_slide} and {.code epix_slide} do not support `.col_names`; + consider:", + "*" = "using {.code epi_slide_mean}, {.code epi_slide_sum}, or + {.code epi_slide_opt}, if applicable", + "*" = "using {.code .f = ~ .x %>% + dplyr::reframe(across(your_col_names, list(your_func_name = your_func)))}" + ), + call = .call, + class = "epiprocess__as_slide_computation__given_.col_names" + ) + } + + f_arg <- .f_arg # for cli interpolation, avoid dot prefix; # nolint: object_usage_linter + withCallingHandlers( + { + force(.f) + }, + error = function(e) { + cli_abort( + c("Failed to convert {.code {f_arg}} to a slide computation.", + "*" = "If you were trying to use the formula interface, + maybe you forgot a tilde at the beginning.", + "*" = "If you were trying to use the tidyeval interface, + maybe you forgot to specify the name, + e.g.: `my_output_col_name =`. Note that `.col_names` + is not supported.", + "*" = "If you were trying to use advanced features of the + tidyeval interface such as `!! name_variable :=`, + maybe you forgot the required leading comma.", + "*" = "Something else could have gone wrong; see below." + ), + parent = e, + call = .call, + class = "epiprocess__as_slide_computation__error_forcing_.f" + ) + } + ) if (rlang::is_quosures(.f)) { quosures <- rlang::quos_auto_name(.f) # resolves := among other things @@ -463,10 +502,10 @@ as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_ti } if (length(.f) > 2) { - cli_abort("{.code {arg}} must be a one-sided formula", + cli_abort("{.code {f_arg}} must be a one-sided formula", class = "epiprocess__as_slide_computation__formula_is_twosided", epiprocess__f = .f, - call = call + .call = .call ) } if (rlang::dots_n(...) > 0L) { @@ -486,7 +525,7 @@ as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_ti class = "epiprocess__as_slide_computation__formula_has_no_env", epiprocess__f = .f, epiprocess__f_env = env, - arg = arg, call = call + .f_arg = .f_arg, .call = .call ) } @@ -513,26 +552,32 @@ as_slide_computation <- function(.f, ..., .ref_time_value_long_varnames, .ref_ti class = "epiprocess__as_slide_computation__cant_convert_catchall", epiprocess__f = .f, epiprocess__f_class = class(.f), - arg = arg, - call = call + .f_arg = .f_arg, + .call = .call ) } #' @rdname as_slide_computation +#' @importFrom rlang caller_arg caller_env #' @keywords internal -as_time_slide_computation <- function(.f, ...) { +as_time_slide_computation <- function(.f, ..., .f_arg = caller_arg(.f), .call = caller_env()) { as_slide_computation( .f, ..., + .f_arg = .f_arg, + .call = .call, .ref_time_value_long_varnames = ".ref_time_value", .ref_time_value_label = "reference time value" ) } #' @rdname as_slide_computation +#' @importFrom rlang caller_arg caller_env #' @keywords internal -as_diagonal_slide_computation <- function(.f, ...) { +as_diagonal_slide_computation <- function(.f, ..., .f_arg = caller_arg(.f), .call = caller_env()) { as_slide_computation( .f, ..., + .f_arg = .f_arg, + .call = .call, .ref_time_value_long_varnames = c(".version", ".ref_time_value"), .ref_time_value_label = "version" ) @@ -982,14 +1027,28 @@ guess_period.POSIXt <- function(time_values, time_values_arg = rlang::caller_arg as.numeric(NextMethod(), units = "secs") } -validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRUE, arg_name = rlang::caller_arg(arg)) { - if (!checkmate::test_scalar(arg) || arg < lower) { - cli_abort( - "Slide function expected `{arg_name}` to be a non-null, scalar integer >= {lower}.", - class = "epiprocess__validate_slide_window_arg" - ) +#' Is `x` an "int" with a sensible class? TRUE/FALSE +#' +#' Like [`checkmate::test_int`] but disallowing some non-sensible classes that +#' `test_int` accepts, such as `difftime`s. We rely on [`is.numeric`] to +#' determine class appropriateness; note that `is.numeric` is NOT simply +#' checking for the class to be "numeric" (or else we'd fail on integer class). +#' +#' @param x object +#' @return Boolean +#' +#' @importFrom checkmate test_int +#' @keywords internal +test_sensible_int <- function(x, na.ok = FALSE, lower = -Inf, upper = Inf, # nolint: object_name_linter + tol = sqrt(.Machine$double.eps), null.ok = FALSE) { # nolint: object_name_linter + if (null.ok && is.null(x)) { + TRUE + } else { + is.numeric(x) && test_int(x, na.ok = na.ok, lower = lower, upper = upper, tol = tol) } +} +validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRUE, arg_name = rlang::caller_arg(arg)) { if (time_type == "custom") { cli_abort( "Unsure how to interpret slide units with a custom time type. Consider converting your time @@ -999,31 +1058,45 @@ validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRU } msg <- "" - if (!identical(arg, Inf)) { - if (time_type == "day") { - if (!test_int(arg, lower = 0L) && !(inherits(arg, "difftime") && units(arg) == "days")) { - msg <- glue::glue_collapse(c("difftime with units in days", "non-negative integer", "Inf"), " or ") - } - } else if (time_type == "week") { - if (!(inherits(arg, "difftime") && units(arg) == "weeks")) { - msg <- glue::glue_collapse(c("difftime with units in weeks", "Inf"), " or ") - } - } else if (time_type == "yearmonth") { - if (!test_int(arg, lower = 0L) || inherits(arg, "difftime")) { - msg <- glue::glue_collapse(c("non-negative integer", "Inf"), " or ") - } - } else if (time_type == "integer") { - if (!test_int(arg, lower = 0L) || inherits(arg, "difftime")) { - msg <- glue::glue_collapse(c("non-negative integer", "Inf"), " or ") - } - } else { - msg <- glue::glue_collapse(c("difftime", "non-negative integer", "Inf"), " or ") - } + inf_if_okay <- if (allow_inf) { + "Inf" } else { - if (!allow_inf) { - msg <- glue::glue_collapse(c("a difftime", "a non-negative integer"), " or ") + character(0L) + } + + # nolint start: indentation_linter. + if (time_type == "day") { + if (!(test_sensible_int(arg, lower = lower) || + inherits(arg, "difftime") && length(arg) == 1L && units(arg) == "days" || + allow_inf && identical(arg, Inf) + )) { + msg <- glue::glue_collapse(c("length-1 difftime with units in days", "non-negative integer", inf_if_okay), " or ") + } + } else if (time_type == "week") { + if (!(inherits(arg, "difftime") && length(arg) == 1L && units(arg) == "weeks" || + allow_inf && identical(arg, Inf) + )) { + msg <- glue::glue_collapse(c("length-1 difftime with units in weeks", inf_if_okay), " or ") + } + } else if (time_type == "yearmonth") { + if (!(test_sensible_int(arg, lower = lower) || + allow_inf && identical(arg, Inf) + )) { + msg <- glue::glue_collapse(c("non-negative integer", inf_if_okay), " or ") } + } else if (time_type == "integer") { + if (!(test_sensible_int(arg, lower = lower) || + allow_inf && identical(arg, Inf) + )) { + msg <- glue::glue_collapse(c("non-negative integer", inf_if_okay), " or ") + } + } else { + cli_abort('`epiprocess` internal error: unrecognized time_type: "{time_type}"', + class = "epiprocess__unrecognized_time_type" + ) } + # nolint end + if (msg != "") { cli_abort( "Slide function expected `{arg_name}` to be a {msg}.", diff --git a/man-roxygen/basic-slide-params.R b/man-roxygen/basic-slide-params.R index 8a63a817..dfa2512f 100644 --- a/man-roxygen/basic-slide-params.R +++ b/man-roxygen/basic-slide-params.R @@ -10,7 +10,8 @@ #' with units "days" #' - if time_type is Date and the cadence is weekly, then `.window_size` must #' be a difftime with units "weeks" -#' - if time_type is an integer, then `.window_size` must be an integer +#' - if time_type is an yearmonth or integer, then `.window_size` must be an +#' integer #' #' @param .align The alignment of the sliding window. If `right` (default), then #' the window has its end at the reference time; if `center`, then the window is diff --git a/man/as_slide_computation.Rd b/man/as_slide_computation.Rd index 3db5a940..72526b02 100644 --- a/man/as_slide_computation.Rd +++ b/man/as_slide_computation.Rd @@ -58,13 +58,25 @@ for evaluating quosures as_slide_computation( .f, ..., + .f_arg = caller_arg(.f), + .call = caller_env(), .ref_time_value_long_varnames, .ref_time_value_label ) -as_time_slide_computation(.f, ...) +as_time_slide_computation( + .f, + ..., + .f_arg = caller_arg(.f), + .call = caller_env() +) -as_diagonal_slide_computation(.f, ...) +as_diagonal_slide_computation( + .f, + ..., + .f_arg = caller_arg(.f), + .call = caller_env() +) } \arguments{ \item{...}{Additional arguments to pass to the function or formula diff --git a/man/epi_slide.Rd b/man/epi_slide.Rd index 74929eb1..8029e2a4 100644 --- a/man/epi_slide.Rd +++ b/man/epi_slide.Rd @@ -57,7 +57,8 @@ an integer (which will be interpreted in units of days) or a difftime with units "days" \item if time_type is Date and the cadence is weekly, then \code{.window_size} must be a difftime with units "weeks" -\item if time_type is an integer, then \code{.window_size} must be an integer +\item if time_type is an yearmonth or integer, then \code{.window_size} must be an +integer }} \item{.align}{The alignment of the sliding window. If \code{right} (default), then diff --git a/man/epi_slide_mean.Rd b/man/epi_slide_mean.Rd index 09faefb6..75b83b10 100644 --- a/man/epi_slide_mean.Rd +++ b/man/epi_slide_mean.Rd @@ -8,7 +8,7 @@ epi_slide_mean( .x, .col_names, ..., - .window_size = 1, + .window_size = NULL, .align = c("right", "center", "left"), .ref_time_values = NULL, .all_rows = FALSE @@ -44,7 +44,8 @@ an integer (which will be interpreted in units of days) or a difftime with units "days" \item if time_type is Date and the cadence is weekly, then \code{.window_size} must be a difftime with units "weeks" -\item if time_type is an integer, then \code{.window_size} must be an integer +\item if time_type is an yearmonth or integer, then \code{.window_size} must be an +integer }} \item{.align}{The alignment of the sliding window. If \code{right} (default), then diff --git a/man/epi_slide_opt.Rd b/man/epi_slide_opt.Rd index dcaab3f8..24b813f0 100644 --- a/man/epi_slide_opt.Rd +++ b/man/epi_slide_opt.Rd @@ -10,7 +10,7 @@ epi_slide_opt( .col_names, .f, ..., - .window_size = 1, + .window_size = NULL, .align = c("right", "center", "left"), .ref_time_values = NULL, .all_rows = FALSE @@ -59,7 +59,8 @@ an integer (which will be interpreted in units of days) or a difftime with units "days" \item if time_type is Date and the cadence is weekly, then \code{.window_size} must be a difftime with units "weeks" -\item if time_type is an integer, then \code{.window_size} must be an integer +\item if time_type is an yearmonth or integer, then \code{.window_size} must be an +integer }} \item{.align}{The alignment of the sliding window. If \code{right} (default), then diff --git a/man/epi_slide_sum.Rd b/man/epi_slide_sum.Rd index 0c83c432..2cf05cca 100644 --- a/man/epi_slide_sum.Rd +++ b/man/epi_slide_sum.Rd @@ -8,7 +8,7 @@ epi_slide_sum( .x, .col_names, ..., - .window_size = 1, + .window_size = NULL, .align = c("right", "center", "left"), .ref_time_values = NULL, .all_rows = FALSE @@ -44,7 +44,8 @@ an integer (which will be interpreted in units of days) or a difftime with units "days" \item if time_type is Date and the cadence is weekly, then \code{.window_size} must be a difftime with units "weeks" -\item if time_type is an integer, then \code{.window_size} must be an integer +\item if time_type is an yearmonth or integer, then \code{.window_size} must be an +integer }} \item{.align}{The alignment of the sliding window. If \code{right} (default), then diff --git a/man/test_sensible_int.Rd b/man/test_sensible_int.Rd new file mode 100644 index 00000000..eda7aacb --- /dev/null +++ b/man/test_sensible_int.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{test_sensible_int} +\alias{test_sensible_int} +\title{Is \code{x} an "int" with a sensible class? TRUE/FALSE} +\usage{ +test_sensible_int( + x, + na.ok = FALSE, + lower = -Inf, + upper = Inf, + tol = sqrt(.Machine$double.eps), + null.ok = FALSE +) +} +\arguments{ +\item{x}{object} +} +\value{ +Boolean +} +\description{ +Like \code{\link[checkmate:checkInt]{checkmate::test_int}} but disallowing some non-sensible classes that +\code{test_int} accepts, such as \code{difftime}s. We rely on \code{\link{is.numeric}} to +determine class appropriateness; note that \code{is.numeric} is NOT simply +checking for the class to be "numeric" (or else we'd fail on integer class). +} +\keyword{internal} diff --git a/tests/testthat/_snaps/utils.md b/tests/testthat/_snaps/utils.md new file mode 100644 index 00000000..a9ee3acb --- /dev/null +++ b/tests/testthat/_snaps/utils.md @@ -0,0 +1,40 @@ +# as_slide_computation raises errors as expected + + Code + toy_edf %>% group_by(geo_value) %>% epi_slide(.window_size = 7, mean, + .col_names = "value") + Condition + Error in `epi_slide()`: + ! `epi_slide` and `epix_slide` do not support `.col_names`; consider: + * using `epi_slide_mean`, `epi_slide_sum`, or `epi_slide_opt`, if applicable + * using `.f = ~ .x %>% dplyr::reframe(across(your_col_names, list(your_func_name = your_func)))` + +--- + + Code + toy_edf %>% group_by(geo_value) %>% epi_slide(.window_size = 7, tibble( + slide_value = mean(.x$value))) + Condition + Error in `epi_slide()`: + ! Failed to convert `tibble(slide_value = mean(.x$value))` to a slide computation. + * If you were trying to use the formula interface, maybe you forgot a tilde at the beginning. + * If you were trying to use the tidyeval interface, maybe you forgot to specify the name, e.g.: `my_output_col_name =`. Note that `.col_names` is not supported. + * If you were trying to use advanced features of the tidyeval interface such as `!! name_variable :=`, maybe you forgot the required leading comma. + * Something else could have gone wrong; see below. + Caused by error: + ! object '.x' not found + +--- + + Code + toy_archive %>% epix_slide(tibble(slide_value = mean(.x$value))) + Condition + Error in `epix_slide()`: + ! Failed to convert `.f` to a slide computation. + * If you were trying to use the formula interface, maybe you forgot a tilde at the beginning. + * If you were trying to use the tidyeval interface, maybe you forgot to specify the name, e.g.: `my_output_col_name =`. Note that `.col_names` is not supported. + * If you were trying to use advanced features of the tidyeval interface such as `!! name_variable :=`, maybe you forgot the required leading comma. + * Something else could have gone wrong; see below. + Caused by error: + ! object '.x' not found + diff --git a/tests/testthat/test-epi_slide.R b/tests/testthat/test-epi_slide.R index d644e9a7..f658bcf4 100644 --- a/tests/testthat/test-epi_slide.R +++ b/tests/testthat/test-epi_slide.R @@ -711,17 +711,9 @@ test_that("epi_slide_opt helper `full_date_seq` returns expected date values", { test_that("`epi_slide_opt` errors when passed non-`data.table`, non-`slider` functions", { reexport_frollmean <- data.table::frollmean - expect_no_error( - epi_slide_opt( - test_data, - .col_names = value, .f = reexport_frollmean - ) - ) + expect_no_error(epi_slide_opt(test_data, .col_names = value, .f = reexport_frollmean, .window_size = 7)) expect_error( - epi_slide_opt( - test_data, - .col_names = value, .f = mean - ), + epi_slide_opt(test_data, .col_names = value, .f = mean), class = "epiprocess__epi_slide_opt__unsupported_slide_function" ) }) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index a159f98e..c5e6c5aa 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -230,6 +230,37 @@ test_that("as_slide_computation raises errors as expected", { expect_error(as_time_slide_computation(5), class = "epiprocess__as_slide_computation__cant_convert_catchall" ) + + # helper to make initial snapshots less error-prone: + expect_error_snapshot <- function(x, class) { + x_quo <- rlang::enquo(x) + rlang::inject(expect_error(!!x_quo, class = class)) # quick sanity check on class + rlang::inject(expect_snapshot(!!x_quo, error = TRUE)) # don't need cnd_class = TRUE since checked above + } + + # If `.f` doesn't look like tidyeval and we fail to force it, then we hint to + # the user some potential problems: + toy_edf <- tibble(geo_value = 1, time_value = c(1, 2), value = 1:2) %>% + as_epi_df(as_of = 1) + toy_archive <- tibble(version = c(1, 2, 2), geo_value = 1, time_value = c(1, 1, 2), value = 1:3) %>% + as_epi_archive() + expect_error_snapshot( + toy_edf %>% + group_by(geo_value) %>% + epi_slide(.window_size = 7, mean, .col_names = "value"), + class = "epiprocess__as_slide_computation__given_.col_names" + ) + expect_error_snapshot( + toy_edf %>% + group_by(geo_value) %>% + epi_slide(.window_size = 7, tibble(slide_value = mean(.x$value))), + class = "epiprocess__as_slide_computation__error_forcing_.f" + ) + expect_error_snapshot( + toy_archive %>% + epix_slide(tibble(slide_value = mean(.x$value))), + class = "epiprocess__as_slide_computation__error_forcing_.f" + ) }) test_that("as_slide_computation works", { @@ -306,15 +337,28 @@ test_that("validate_slide_window_arg works", { } expect_no_error(validate_slide_window_arg(as.difftime(1, units = "days"), "day")) expect_no_error(validate_slide_window_arg(1, "day")) - expect_no_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "day")) + expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "day"), + class = "epiprocess__validate_slide_window_arg" + ) + expect_error(validate_slide_window_arg(as.difftime(1, units = "secs"), "day"), + class = "epiprocess__validate_slide_window_arg" + ) expect_no_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "week")) - expect_error(validate_slide_window_arg(1, "week")) + expect_error(validate_slide_window_arg(1, "week"), + class = "epiprocess__validate_slide_window_arg" + ) expect_no_error(validate_slide_window_arg(1, "integer")) - expect_error(validate_slide_window_arg(as.difftime(1, units = "days"), "integer")) - expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "integer")) + expect_error(validate_slide_window_arg(as.difftime(1, units = "days"), "integer"), + class = "epiprocess__validate_slide_window_arg" + ) + expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "integer"), + class = "epiprocess__validate_slide_window_arg" + ) expect_no_error(validate_slide_window_arg(1, "yearmonth")) - expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "yearmonth")) + expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "yearmonth"), + class = "epiprocess__validate_slide_window_arg" + ) })