Skip to content

Commit 76bb747

Browse files
committed
Complete docs and match code&messages wrt .window_size validation
* 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).
1 parent d9cf933 commit 76bb747

File tree

9 files changed

+111
-44
lines changed

9 files changed

+111
-44
lines changed

R/slide.R

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -576,7 +576,7 @@ get_before_after_from_window <- function(window_size, align, time_type) {
576576
#' ungroup()
577577
epi_slide_opt <- function(
578578
.x, .col_names, .f, ...,
579-
.window_size = 1, .align = c("right", "center", "left"),
579+
.window_size = NULL, .align = c("right", "center", "left"),
580580
.ref_time_values = NULL, .all_rows = FALSE) {
581581
assert_class(.x, "epi_df")
582582

@@ -902,7 +902,7 @@ epi_slide_opt <- function(
902902
#' ungroup()
903903
epi_slide_mean <- function(
904904
.x, .col_names, ...,
905-
.window_size = 1, .align = c("right", "center", "left"),
905+
.window_size = NULL, .align = c("right", "center", "left"),
906906
.ref_time_values = NULL, .all_rows = FALSE) {
907907
# Deprecated argument handling
908908
provided_args <- rlang::call_args_names(rlang::call_match())
@@ -979,7 +979,7 @@ epi_slide_mean <- function(
979979
#' ungroup()
980980
epi_slide_sum <- function(
981981
.x, .col_names, ...,
982-
.window_size = 1, .align = c("right", "center", "left"),
982+
.window_size = NULL, .align = c("right", "center", "left"),
983983
.ref_time_values = NULL, .all_rows = FALSE) {
984984
# Deprecated argument handling
985985
provided_args <- rlang::call_args_names(rlang::call_match())

R/utils.R

Lines changed: 55 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -982,14 +982,31 @@ guess_period.POSIXt <- function(time_values, time_values_arg = rlang::caller_arg
982982
as.numeric(NextMethod(), units = "secs")
983983
}
984984

985-
validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRUE, arg_name = rlang::caller_arg(arg)) {
986-
if (!checkmate::test_scalar(arg) || arg < lower) {
987-
cli_abort(
988-
"Slide function expected `{arg_name}` to be a non-null, scalar integer >= {lower}.",
989-
class = "epiprocess__validate_slide_window_arg"
985+
#' Is `x` an "int" with a sensible class? TRUE/FALSE
986+
#'
987+
#' Like [`checkmate::test_int`] but disallowing some non-sensible classes that
988+
#' `test_int` accepts, such as `difftime`s. We rely on [`is.numeric`] to
989+
#' determine class appropriateness; note that `is.numeric` is NOT simply
990+
#' checking for the class to be "numeric" (or else we'd fail on integer class).
991+
#'
992+
#' @param x object
993+
#' @return Boolean
994+
#'
995+
#' @importFrom checkmate test_int
996+
#' @keywords internal
997+
test_sensible_int <- function(x, na.ok = FALSE, lower = -Inf, upper = Inf,
998+
tol = sqrt(.Machine$double.eps), null.ok = FALSE) {
999+
if (null.ok && is.null(x)) {
1000+
TRUE
1001+
} else {
1002+
is.numeric(x) && test_int(x,
1003+
na.ok = FALSE, lower = -Inf, upper = Inf,
1004+
tol = sqrt(.Machine$double.eps)
9901005
)
9911006
}
1007+
}
9921008

1009+
validate_slide_window_arg <- function(arg, time_type, lower = 1, allow_inf = TRUE, arg_name = rlang::caller_arg(arg)) {
9931010
if (time_type == "custom") {
9941011
cli_abort(
9951012
"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
9991016
}
10001017

10011018
msg <- ""
1002-
if (!identical(arg, Inf)) {
1003-
if (time_type == "day") {
1004-
if (!test_int(arg, lower = 0L) || inherits(arg, "difftime") && units(arg) != "days") {
1005-
msg <- glue::glue_collapse(c("difftime with units in days", "non-negative integer", "Inf"), " or ")
1006-
}
1007-
} else if (time_type == "week") {
1008-
if (!(inherits(arg, "difftime") && units(arg) == "weeks")) {
1009-
msg <- glue::glue_collapse(c("difftime with units in weeks", "Inf"), " or ")
1010-
}
1011-
} else if (time_type == "yearmonth") {
1012-
if (!test_int(arg, lower = 0L) || inherits(arg, "difftime")) {
1013-
msg <- glue::glue_collapse(c("non-negative integer", "Inf"), " or ")
1014-
}
1015-
} else if (time_type == "integer") {
1016-
if (!test_int(arg, lower = 0L) || inherits(arg, "difftime")) {
1017-
msg <- glue::glue_collapse(c("non-negative integer", "Inf"), " or ")
1018-
}
1019-
} else {
1020-
msg <- glue::glue_collapse(c("difftime", "non-negative integer", "Inf"), " or ")
1021-
}
1019+
inf_if_okay <- if (allow_inf) {
1020+
"Inf"
10221021
} else {
1023-
if (!allow_inf) {
1024-
msg <- glue::glue_collapse(c("a difftime", "a non-negative integer"), " or ")
1022+
character(0L)
1023+
}
1024+
1025+
if (time_type == "day") {
1026+
if (!(test_sensible_int(arg, lower = 0L) ||
1027+
inherits(arg, "difftime") && length(arg) == 1L && units(arg) == "days" ||
1028+
allow_inf && identical(arg, Inf)
1029+
)) {
1030+
msg <- glue::glue_collapse(c("length-1 difftime with units in days", "non-negative integer", inf_if_okay), " or ")
10251031
}
1032+
} else if (time_type == "week") {
1033+
if (!(inherits(arg, "difftime") && length(arg) == 1L && units(arg) == "weeks" ||
1034+
allow_inf && identical(arg, Inf)
1035+
)) {
1036+
msg <- glue::glue_collapse(c("length-1 difftime with units in weeks", inf_if_okay), " or ")
1037+
}
1038+
} else if (time_type == "yearmonth") {
1039+
if (!(test_sensible_int(arg, lower = 0L) ||
1040+
allow_inf && identical(arg, Inf)
1041+
)) {
1042+
msg <- glue::glue_collapse(c("non-negative integer", inf_if_okay), " or ")
1043+
}
1044+
} else if (time_type == "integer") {
1045+
if (!(test_sensible_int(arg, lower = 0L) ||
1046+
allow_inf && identical(arg, Inf)
1047+
)) {
1048+
msg <- glue::glue_collapse(c("non-negative integer", inf_if_okay), " or ")
1049+
}
1050+
} else {
1051+
cli_abort('`epiprocess` internal error: unrecognized time_type: "{time_type}"',
1052+
class = "epiprocess__unrecognized_time_type")
10261053
}
1054+
10271055
if (msg != "") {
10281056
cli_abort(
10291057
"Slide function expected `{arg_name}` to be a {msg}.",

man-roxygen/basic-slide-params.R

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,8 @@
1010
#' with units "days"
1111
#' - if time_type is Date and the cadence is weekly, then `.window_size` must
1212
#' be a difftime with units "weeks"
13-
#' - if time_type is an integer, then `.window_size` must be an integer
13+
#' - if time_type is an yearmonth or integer, then `.window_size` must be an
14+
#' integer
1415
#'
1516
#' @param .align The alignment of the sliding window. If `right` (default), then
1617
#' the window has its end at the reference time; if `center`, then the window is

man/epi_slide.Rd

Lines changed: 2 additions & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

man/epi_slide_mean.Rd

Lines changed: 3 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

man/epi_slide_opt.Rd

Lines changed: 3 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

man/epi_slide_sum.Rd

Lines changed: 3 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

man/test_sensible_int.Rd

Lines changed: 28 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

tests/testthat/test-utils.R

Lines changed: 12 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -306,16 +306,22 @@ test_that("validate_slide_window_arg works", {
306306
}
307307
expect_no_error(validate_slide_window_arg(as.difftime(1, units = "days"), "day"))
308308
expect_no_error(validate_slide_window_arg(1, "day"))
309-
expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "day"))
310-
expect_error(validate_slide_window_arg(as.difftime(1, units = "secs"), "day"))
309+
expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "day"),
310+
class = "epiprocess__validate_slide_window_arg")
311+
expect_error(validate_slide_window_arg(as.difftime(1, units = "secs"), "day"),
312+
class = "epiprocess__validate_slide_window_arg")
311313

312314
expect_no_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "week"))
313-
expect_error(validate_slide_window_arg(1, "week"))
315+
expect_error(validate_slide_window_arg(1, "week"),
316+
class = "epiprocess__validate_slide_window_arg")
314317

315318
expect_no_error(validate_slide_window_arg(1, "integer"))
316-
expect_error(validate_slide_window_arg(as.difftime(1, units = "days"), "integer"))
317-
expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "integer"))
319+
expect_error(validate_slide_window_arg(as.difftime(1, units = "days"), "integer"),
320+
class = "epiprocess__validate_slide_window_arg")
321+
expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "integer"),
322+
class = "epiprocess__validate_slide_window_arg")
318323

319324
expect_no_error(validate_slide_window_arg(1, "yearmonth"))
320-
expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "yearmonth"))
325+
expect_error(validate_slide_window_arg(as.difftime(1, units = "weeks"), "yearmonth"),
326+
class = "epiprocess__validate_slide_window_arg")
321327
})

0 commit comments

Comments
 (0)