diff --git a/R/slide.R b/R/slide.R index 5a7fbd6a..b971b9d5 100644 --- a/R/slide.R +++ b/R/slide.R @@ -576,7 +576,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") @@ -902,7 +902,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 +979,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 88c7eaa0..32dcb492 100644 --- a/R/utils.R +++ b/R/utils.R @@ -982,14 +982,31 @@ 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, + tol = sqrt(.Machine$double.eps), null.ok = FALSE) { + if (null.ok && is.null(x)) { + TRUE + } else { + is.numeric(x) && test_int(x, + na.ok = FALSE, lower = -Inf, upper = Inf, + tol = sqrt(.Machine$double.eps) ) } +} +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 +1016,42 @@ 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) + } + + if (time_type == "day") { + if (!(test_sensible_int(arg, lower = 0L) || + 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 = 0L) || + 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 = 0L) || + 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") } + 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/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/test-utils.R b/tests/testthat/test-utils.R index 5767751d..a248a041 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -306,16 +306,22 @@ 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_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "day")) - expect_error(validate_slide_window_arg(as.difftime(1, units = "secs"), "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") })