From 882e9607ec017ff5a963fcfd1a965daaede6ea09 Mon Sep 17 00:00:00 2001 From: "Logan C. Brooks" Date: Tue, 12 Nov 2024 11:38:41 -0800 Subject: [PATCH] Use different automatic names for slides on logical columns --- R/slide.R | 34 +++++++++++++++++---------------- R/utils.R | 5 +++++ man/epi_slide_opt.Rd | 3 ++- tests/testthat/test-epi_slide.R | 25 ++++++++++++++++++++++++ 4 files changed, 50 insertions(+), 17 deletions(-) diff --git a/R/slide.R b/R/slide.R index 9d383446d..96beb8280 100644 --- a/R/slide.R +++ b/R/slide.R @@ -587,7 +587,8 @@ get_before_after_from_window <- function(window_size, align, time_type) { #' `time_type` of `.x` #' - `{.align_abbr}` will be `""` if `.align` is the default of `"right"`; #' otherwise, it will be the first letter of `.align` -#' - `{.f_abbr}` will be a short string based on what `.f` +#' - `{.f_abbr}` will be a character vector containing a short abbreviation +#' for `.f` factoring in the input column type(s) for `.col_names` #' #' @importFrom dplyr bind_rows mutate %>% arrange tibble select all_of #' @importFrom rlang enquo expr_label caller_arg quo_get_env @@ -681,22 +682,23 @@ epi_slide_opt <- function( col_names_chr <- names(.x)[pos] # Check that slide function `.f` is one of those short-listed from - # `data.table` and `slider` (or a function that has the exact same - # definition, e.g. if the function has been reexported or defined - # locally). + # `data.table` and `slider` (or a function that has the exact same definition, + # e.g. if the function has been reexported or defined locally). Extract some + # metadata. `namer` will be mapped over columns (.x will be a column, not the + # entire edf). f_possibilities <- tibble::tribble( - ~f, ~package, ~abbr, - frollmean, "data.table", "av", - frollsum, "data.table", "sum", - frollapply, "data.table", "slide", - slide_sum, "slider", "sum", - slide_prod, "slider", "prod", - slide_mean, "slider", "av", - slide_min, "slider", "min", - slide_max, "slider", "max", - slide_all, "slider", "all", - slide_any, "slider", "any", + ~f, ~package, ~namer, + frollmean, "data.table", ~ if (is.logical(.x)) "prop" else "av", + frollsum, "data.table", ~ if (is.logical(.x)) "count" else "sum", + frollapply, "data.table", ~"slide", + slide_sum, "slider", ~ if (is.logical(.x)) "count" else "sum", + slide_prod, "slider", ~"prod", + slide_mean, "slider", ~ if (is.logical(.x)) "prop" else "av", + slide_min, "slider", ~"min", + slide_max, "slider", ~"max", + slide_all, "slider", ~"all", + slide_any, "slider", ~"any", ) f_info <- f_possibilities %>% filter(map_lgl(.data$f, ~ identical(.f, .x))) @@ -780,7 +782,7 @@ epi_slide_opt <- function( .n = n, .time_unit_abbr = time_unit_abbr, .align_abbr = align_abbr, - .f_abbr = f_info$abbr, + .f_abbr = purrr::map_chr(.x[col_names_chr], unwrap(f_info$namer)), quo_get_env(col_names_quo) ) .new_col_names <- unclass( diff --git a/R/utils.R b/R/utils.R index 06876f08e..6625e5c3e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1174,3 +1174,8 @@ time_type_unit_abbr <- function(time_type) { } maybe_unit_abbr } + +unwrap <- function(x) { + checkmate::assert_list(x, len = 1L, names = "unnamed") + x[[1L]] +} diff --git a/man/epi_slide_opt.Rd b/man/epi_slide_opt.Rd index 7f250cf4f..c4526c0e7 100644 --- a/man/epi_slide_opt.Rd +++ b/man/epi_slide_opt.Rd @@ -155,7 +155,8 @@ corresponding to the \code{.window_size}. \code{time_type} of \code{.x} \item \code{{.align_abbr}} will be \code{""} if \code{.align} is the default of \code{"right"}; otherwise, it will be the first letter of \code{.align} -\item \code{{.f_abbr}} will be a short string based on what \code{.f} +\item \code{{.f_abbr}} will be a character vector containing a short abbreviation +for \code{.f} factoring in the input column type(s) for \code{.col_names} } } diff --git a/tests/testthat/test-epi_slide.R b/tests/testthat/test-epi_slide.R index e8c318c71..2cb04eec5 100644 --- a/tests/testthat/test-epi_slide.R +++ b/tests/testthat/test-epi_slide.R @@ -812,8 +812,24 @@ test_that("epi_slide_opt output naming features", { yearmonthly %>% epi_slide_opt(value, slide_any, .window_size = 3) %>% names(), c(names(yearmonthly), "value_3many") # not the best name, but super unlikely anyway ) + # * Through forwarding functions: + expect_equal( + # XXX perhaps this should be an auto-naming feature? + yearmonthly %>% + epi_slide_mean(value, .window_size = Inf) %>% + names(), + c(names(yearmonthly), "value_running_prop") + ) + expect_equal( + # XXX perhaps this should be an auto-naming feature? + yearmonthly %>% + epi_slide_sum(value, .window_size = Inf) %>% + names(), + c(names(yearmonthly), "value_running_count") + ) # Manual naming: + # * Various combinations of args: expect_equal( multi_columns %>% epi_slide_opt(starts_with("value"), slide_sum, .window_size = 7, .suffix = "_s{.n}") %>% @@ -838,6 +854,15 @@ test_that("epi_slide_opt output naming features", { names(), c(names(multi_columns), "slide_value", "sv2") ) + # * Through forwarding functions: + expect_equal( + yearmonthly %>% epi_slide_mean(value, .window_size = Inf, .suffix = "_{.f_abbr}") %>% names(), + c(names(yearmonthly), "value_prop") + ) + expect_equal( + yearmonthly %>% epi_slide_sum(value, .window_size = Inf, .suffix = "_{.f_abbr}") %>% names(), + c(names(yearmonthly), "value_count") + ) # Validation errors: # * Wrong sizes: