diff --git a/R/slide.R b/R/slide.R index e1e00c58..a3e6e652 100644 --- a/R/slide.R +++ b/R/slide.R @@ -646,7 +646,7 @@ epi_slide_opt <- function( if ("new_col_name" %in% provided_args || ".new_col_name" %in% provided_args) { cli::cli_abort( "epi_slide_opt: the argument `new_col_name` is not supported for `epi_slide_opt`. If you want to customize - the output column names, use `dplyr::rename` after the slide.", + the output column names, use `.prefix =`, `.suffix =`, or `.new_col_**names** =`.", class = "epiprocess__epi_slide_opt__new_name_not_supported" ) } @@ -746,14 +746,15 @@ epi_slide_opt <- function( window_args <- get_before_after_from_window(.window_size, .align, time_type) # Handle output naming - assert_string(.prefix, null.ok = TRUE) - assert_string(.suffix, null.ok = TRUE) - assert_character(.new_col_names, len = length(col_names_chr), null.ok = TRUE) if ((!is.null(.prefix) || !is.null(.suffix)) && !is.null(.new_col_names)) { cli_abort( - "Can't use both .prefix/.suffix and .new_col_names at the same time." + "Can't use both .prefix/.suffix and .new_col_names at the same time.", + class = "epiprocess__epi_slide_opt_incompatible_naming_args" ) } + assert_string(.prefix, null.ok = TRUE) + assert_string(.suffix, null.ok = TRUE) + assert_character(.new_col_names, len = length(col_names_chr), null.ok = TRUE) if (is.null(.prefix) && is.null(.suffix) && is.null(.new_col_names)) { .suffix <- "_{.n}{.time_unit_abbr}{.align_abbr}{.f_abbr}" # ^ does not account for any arguments specified to underlying functions via diff --git a/R/utils.R b/R/utils.R index 9caa6ad5..06876f08 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1137,7 +1137,7 @@ time_delta_to_n_steps <- function(time_delta, time_type) { week = "weeks", cli_abort("difftime objects not supported for time_type {format_chr_with_quotes(time_type)}") ) - units(time_delta) <- output_units # converts number accordingly, doesn't just set attr + units(time_delta) <- output_units # converts number to represent same duration; not just attr<- n_steps <- vec_data(time_delta) if (!is_bare_integerish(n_steps)) { cli_abort("`time_delta` did not appear to contain only integerish numbers @@ -1164,7 +1164,7 @@ time_delta_to_n_steps <- function(time_delta, time_type) { time_type_unit_abbrs <- c( day = "d", week = "w", - yearmon = "m" + yearmonth = "m" ) time_type_unit_abbr <- function(time_type) { diff --git a/man/time_delta_to_n_steps.Rd b/man/time_delta_to_n_steps.Rd new file mode 100644 index 00000000..0f9325be --- /dev/null +++ b/man/time_delta_to_n_steps.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{time_delta_to_n_steps} +\alias{time_delta_to_n_steps} +\title{Convert a time delta to a compatible integerish number of steps between time values} +\usage{ +time_delta_to_n_steps(time_delta, time_type) +} +\arguments{ +\item{time_delta}{a vector that can be added to time values of time type +\code{time_type} to arrive at other time values of that time type, or +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} such a vector with Inf/-Inf entries mixed +in, if supported by the class of \code{time_delta}, even if \code{time_type} doesn't +necessarily support Inf/-Inf entries. Basically a slide window arg but +without sign and length restrictions.} + +\item{time_type}{as in \code{\link{validate_slide_window_arg}}} +} +\value{ +\link[rlang:is_integerish]{bare integerish} vector (with possible +infinite values) that produces the same result as \code{time_delta} when added +to time values of time type \code{time_type}. If the given time type does not +support infinite values, then it should produce +Inf or -Inf for analogous +entries of \code{time_delta}, and match the addition result match the addition +result for non-infinite values, and product +Inf / -Inf when match the sign +and of \code{time_delta}. +} +\description{ +Convert a time delta to a compatible integerish number of steps between time values +} +\keyword{internal} diff --git a/tests/testthat/test-epi_slide.R b/tests/testthat/test-epi_slide.R index 006368d0..8e9f3122 100644 --- a/tests/testthat/test-epi_slide.R +++ b/tests/testthat/test-epi_slide.R @@ -755,3 +755,98 @@ test_that("no dplyr warnings from selecting multiple columns", { ) expect_equal(multi_slid_select, multi_slid) }) + +test_that("epi_slide_opt output naming features", { + multi_columns <- dplyr::bind_rows( + dplyr::tibble(geo_value = "ak", time_value = test_date + 1:200, value = 1:200, value2 = -1:-200), + dplyr::tibble(geo_value = "al", time_value = test_date + 1:5, value = -(1:5), value2 = 1:5) + ) %>% + as_epi_df() %>% + group_by(geo_value) + multi_columns_weekly <- dplyr::bind_rows( + dplyr::tibble(geo_value = "ak", time_value = test_date + 7 * (1:200), value = 1:200, value2 = -1:-200), + dplyr::tibble(geo_value = "al", time_value = test_date + 7 * (1:5), value = -(1:5), value2 = 1:5) + ) %>% + as_epi_df() %>% + group_by(geo_value) + yearmonthly <- + tibble::tibble( + geo_value = 1, + time_value = tsibble::make_yearmonth(2000, 1) + 1:30 - 1, + value = 1:30 %% 2 == 0 + ) %>% + as_epi_df() %>% + group_by(geo_value) + + # Auto-naming: + # * Changing .f and .window_size: + expect_equal( + multi_columns %>% epi_slide_opt(value2, frollmean, .window_size = 14) %>% names(), + c(names(multi_columns), "value2_14dav") + ) + expect_equal( + multi_columns %>% epi_slide_opt(value2, slide_mean, .window_size = as.difftime(14, units = "days")) %>% names(), + c(names(multi_columns), "value2_14dav") + ) + expect_equal( + multi_columns %>% epi_slide_opt(value2, slide_sum, .window_size = Inf) %>% names(), + c(names(multi_columns), "value2_running_sum") + ) + # * Changing .f and .align: + expect_equal( + multi_columns %>% epi_slide_opt(value2, slide_min, .window_size = 14, .align = "center") %>% names(), + c(names(multi_columns), "value2_14dcmin") + ) + expect_equal( + multi_columns %>% epi_slide_opt(value2, slide_max, .window_size = 14, .align = "left") %>% names(), + c(names(multi_columns), "value2_14dlmax") + ) + # * Changing .f, time_type(, .window_size): + expect_equal( + multi_columns_weekly %>% epi_slide_opt(value2, slide_prod, .window_size = as.difftime(2, units = "weeks")) %>% names(), + c(names(multi_columns_weekly), "value2_2wprod") + ) + expect_equal( + yearmonthly %>% epi_slide_opt(value, slide_any, .window_size = 3) %>% names(), + c(names(yearmonthly), "value_3many") # not the best name, but super unlikely anyway + ) + + # Manual naming: + expect_equal( + multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, .window_size = 7, .suffix = "_s{.n}") %>% names(), + c(names(multi_columns), "value_s7", "value2_s7") + ) + expect_equal( + multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, .window_size = 7, .prefix = "{.f_abbr}_", .suffix = "_{.n}") %>% names(), + c(names(multi_columns), "sum_value_7", "sum_value2_7") + ) + expect_equal( + multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, .window_size = 7, .prefix = "slide_value_") %>% names(), + c(names(multi_columns), "slide_value_value", "slide_value_value2") + ) + expect_equal( + multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, .window_size = 7, .new_col_names = c("slide_value", "sv2")) %>% names(), + c(names(multi_columns), "slide_value", "sv2") + ) + + # Validation errors: + expect_error( + multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, + .window_size = 7, + .suffix = c("a", "b") + ) + ) + expect_error( + multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, + .window_size = 7, + .new_col_names = "slide_value" + ) + ) + expect_error( + multi_columns %>% epi_slide_opt(value, slide_sum, + .window_size = 7, + .prefix = "a", .suffix = "b", .new_col_names = "slide_value" + ), + class = "epiprocess__epi_slide_opt_incompatible_naming_args" + ) +})