Skip to content

Commit

Permalink
Complete docs and match code&messages wrt .window_size validation
Browse files Browse the repository at this point in the history
* Mention what's acceptable for yearmonth time_type
* Mention Inf in validation errors as acceptable iff it's actually acceptible.
* Refactor to use helper function test_sensible_int instead of test_int (as
  latter accepts difftimes and makes logic look confusing).
  • Loading branch information
brookslogan committed Oct 1, 2024
1 parent d9cf933 commit 76bb747
Show file tree
Hide file tree
Showing 9 changed files with 111 additions and 44 deletions.
6 changes: 3 additions & 3 deletions R/slide.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")

Expand Down Expand Up @@ -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())
Expand Down Expand Up @@ -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())
Expand Down
82 changes: 55 additions & 27 deletions R/utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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}.",
Expand Down
3 changes: 2 additions & 1 deletion man-roxygen/basic-slide-params.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion man/epi_slide.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

5 changes: 3 additions & 2 deletions man/epi_slide_mean.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

5 changes: 3 additions & 2 deletions man/epi_slide_opt.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

5 changes: 3 additions & 2 deletions man/epi_slide_sum.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

28 changes: 28 additions & 0 deletions man/test_sensible_int.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

18 changes: 12 additions & 6 deletions tests/testthat/test-utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")
})

0 comments on commit 76bb747

Please sign in to comment.