refactor: key_colnames and others

* key_colnames order change
* replace kill_time_value with exclude arg in key_colnames
* move duplicate time_values check in epi_slide

Author: dshemetov

R/autoplot.R

@@ -55,7 +55,7 @@ autoplot.epi_df <- function(
 
   key_cols <- key_colnames(object)
   non_key_cols <- setdiff(names(object), key_cols)
-  geo_and_other_keys <- kill_time_value(key_cols)
+  geo_and_other_keys <- key_colnames(object, exclude = "time_value")
 
   # --- check for numeric variables
   allowed <- purrr::map_lgl(object[non_key_cols], is.numeric)

R/epi_df.R

@@ -184,18 +184,14 @@ new_epi_df <- function(x = tibble::tibble(geo_value = character(), time_value =
   metadata$other_keys <- other_keys
 
   # Reorder columns (geo_value, time_value, ...)
-  if (sum(dim(x)) != 0) {
-    cols_to_put_first <- c("geo_value", "time_value", other_keys)
-    x <- x[, c(
-      cols_to_put_first,
-      # All other columns
-      names(x)[!(names(x) %in% cols_to_put_first)]
-    )]
+  if (nrow(x) > 0) {
+    x <- x %>% relocate(all_of(c("geo_value", other_keys, "time_value")), .before = 1)
   }
 
   # Apply epi_df class, attach metadata, and return
   class(x) <- c("epi_df", class(x))
   attributes(x)$metadata <- metadata
+
   return(x)
 }
 
@@ -281,6 +277,7 @@ as_epi_df.tbl_df <- function(
   if (".time_value_counts" %in% other_keys) {
     cli_abort("as_epi_df: `other_keys` can't include \".time_value_counts\"")
   }
+
   duplicated_time_values <- x %>%
     group_by(across(all_of(c("geo_value", "time_value", other_keys)))) %>%
     filter(dplyr::n() > 1) %>%

R/grouped_epi_archive.R

@@ -397,8 +397,8 @@ epix_slide.grouped_epi_archive <- function(
               )),
               capture.output(print(waldo::compare(
                 res[[comp_nms[[comp_i]]]], comp_value[[comp_i]],
-                x_arg = rlang::expr_deparse(expr(`$`(label, !!sym(comp_nms[[comp_i]])))),
-                y_arg = rlang::expr_deparse(expr(`$`(comp_value, !!sym(comp_nms[[comp_i]]))))
+                x_arg = rlang::expr_deparse(dplyr::expr(`$`(label, !!sym(comp_nms[[comp_i]])))), # nolint: object_usage_linter
+                y_arg = rlang::expr_deparse(dplyr::expr(`$`(comp_value, !!sym(comp_nms[[comp_i]]))))
               ))),
               cli::format_message(c(
                 "You likely want to rename or remove this column in your output, or debug why it has a different value."

R/key_colnames.R

@@ -2,6 +2,7 @@
 #'
 #' @param x a data.frame, tibble, or epi_df
 #' @param ... additional arguments passed on to methods
+#' @param exclude an optional character vector of keys to exclude
 #'
 #' @return If an `epi_df`, this returns all "keys". Otherwise `NULL`
 #' @keywords internal
@@ -16,25 +17,23 @@ key_colnames.default <- function(x, ...) {
 }
 
 #' @export
-key_colnames.data.frame <- function(x, other_keys = character(0L), ...) {
+key_colnames.data.frame <- function(x, other_keys = character(0L), exclude = character(0L), ...) {
   assert_character(other_keys)
-  nm <- c("geo_value", "time_value", other_keys)
+  assert_character(exclude)
+  nm <- setdiff(c("geo_value", other_keys, "time_value"), exclude)
   intersect(nm, colnames(x))
 }
 
 #' @export
-key_colnames.epi_df <- function(x, ...) {
+key_colnames.epi_df <- function(x, exclude = character(0L), ...) {
+  assert_character(exclude)
   other_keys <- attr(x, "metadata")$other_keys
-  c("geo_value", "time_value", other_keys)
+  setdiff(c("geo_value", other_keys, "time_value"), exclude)
 }
 
 #' @export
-key_colnames.epi_archive <- function(x, ...) {
+key_colnames.epi_archive <- function(x, exclude = character(0L), ...) {
+  assert_character(exclude)
   other_keys <- attr(x, "metadata")$other_keys
-  c("geo_value", "time_value", other_keys)
-}
-
-kill_time_value <- function(v) {
-  assert_character(v)
-  v[v != "time_value"]
+  setdiff(c("geo_value", other_keys, "time_value"), exclude)
 }

R/methods-epi_df.R

@@ -41,10 +41,13 @@ as_tibble.epi_df <- function(x, ...) {
 #' @export
 as_tsibble.epi_df <- function(x, key, ...) {
   if (missing(key)) key <- c("geo_value", attributes(x)$metadata$other_keys)
-  return(as_tsibble(tibble::as_tibble(x),
-    key = tidyselect::all_of(key), index = "time_value",
-    ...
-  ))
+  return(
+    as_tsibble(
+      tibble::as_tibble(x),
+      key = tidyselect::all_of(key), index = "time_value",
+      ...
+    )
+  )
 }
 
 #' Base S3 methods for an `epi_df` object
@@ -150,10 +153,10 @@ dplyr_reconstruct.epi_df <- function(data, template) {
   # keep any grouping that has been applied:
   res <- NextMethod()
 
-  cn <- names(res)
+  col_names <- names(res)
 
   # Duplicate columns, cli_abort
-  dup_col_names <- cn[duplicated(cn)]
+  dup_col_names <- col_names[duplicated(col_names)]
   if (length(dup_col_names) != 0) {
     cli_abort(c(
       "Duplicate column names are not allowed",
@@ -163,7 +166,7 @@ dplyr_reconstruct.epi_df <- function(data, template) {
     ))
   }
 
-  not_epi_df <- !("time_value" %in% cn) || !("geo_value" %in% cn)
+  not_epi_df <- !("time_value" %in% col_names) || !("geo_value" %in% col_names)
 
   if (not_epi_df) {
     # If we're calling on an `epi_df` from one of our own functions, we need to
@@ -182,7 +185,7 @@ dplyr_reconstruct.epi_df <- function(data, template) {
 
   # Amend additional metadata if some other_keys cols are dropped in the subset
   old_other_keys <- attr(template, "metadata")$other_keys
-  attr(res, "metadata")$other_keys <- old_other_keys[old_other_keys %in% cn]
+  attr(res, "metadata")$other_keys <- old_other_keys[old_other_keys %in% col_names]
 
   res
 }
@@ -425,8 +428,8 @@ arrange_col_canonical.epi_df <- function(x, ...) {
 }
 
 #' @export
-group_epi_df <- function(x) {
-  cols <- kill_time_value(key_colnames(x))
+group_epi_df <- function(x, exclude = character()) {
+  cols <- key_colnames(x, exclude = exclude)
   x %>% group_by(across(all_of(cols)))
 }
 

R/slide.R

@@ -122,8 +122,7 @@ epi_slide <- function(
   assert_class(.x, "epi_df")
   if (checkmate::test_class(.x, "grouped_df")) {
     expected_group_keys <- .x %>%
-      key_colnames() %>%
-      kill_time_value() %>%
+      key_colnames(exclude = "time_value") %>%
       sort()
     if (!identical(.x %>% group_vars() %>% sort(), expected_group_keys)) {
       cli_abort(
@@ -134,12 +133,11 @@ epi_slide <- function(
       )
     }
   } else {
-    .x <- group_epi_df(.x)
+    .x <- group_epi_df(.x, exclude = "time_value")
   }
   if (nrow(.x) == 0L) {
     return(.x)
   }
-
   # If `.f` is missing, interpret ... as an expression for tidy evaluation
   if (missing(.f)) {
     used_data_masking <- TRUE
@@ -191,6 +189,20 @@ epi_slide <- function(
 
   assert_logical(.all_rows, len = 1)
 
+  # Check for duplicated time values within groups
+  duplicated_time_values <- .x %>%
+    group_epi_df() %>%
+    filter(dplyr::n() > 1) %>%
+    ungroup()
+  if (nrow(duplicated_time_values) > 0) {
+    bad_data <- capture.output(duplicated_time_values)
+    cli_abort(
+      "as_epi_df: some groups in a resulting dplyr computation have duplicated time values.
+      epi_df requires a unique time_value per group.",
+      body = c("Sample groups:", bad_data)
+    )
+  }
+
   # Begin handling completion. This will create a complete time index between
   # the smallest and largest time values in the data. This is used to ensure
   # that the slide function is called with a complete window of data. Each slide
@@ -241,7 +253,7 @@ epi_slide <- function(
     .keep = TRUE
   ) %>%
     bind_rows() %>%
-    filter(.data$.real) %>%
+    filter(.real) %>%
     select(-.real) %>%
     arrange_col_canonical() %>%
     group_by(!!!.x_groups)
@@ -275,11 +287,16 @@ epi_slide_one_group <- function(
   missing_times <- all_dates[!(all_dates %in% .data_group$time_value)]
   .data_group <- bind_rows(
     .data_group,
-    tibble(time_value = c(
-      missing_times,
-      .date_seq_list$pad_early_dates,
-      .date_seq_list$pad_late_dates
-    ), .real = FALSE)
+    dplyr::bind_cols(
+      .group_key,
+      tibble(
+        time_value = c(
+          missing_times,
+          .date_seq_list$pad_early_dates,
+          .date_seq_list$pad_late_dates
+        ), .real = FALSE
+      )
+    )
   ) %>%
     arrange(.data$time_value)
 
@@ -405,8 +422,8 @@ epi_slide_one_group <- function(
             )),
             capture.output(print(waldo::compare(
               res[[comp_nms[[comp_i]]]], slide_values[[comp_i]],
-              x_arg = rlang::expr_deparse(expr(`$`(existing, !!sym(comp_nms[[comp_i]])))),
-              y_arg = rlang::expr_deparse(expr(`$`(comp_value, !!sym(comp_nms[[comp_i]]))))
+              x_arg = rlang::expr_deparse(dplyr::expr(`$`(existing, !!sym(comp_nms[[comp_i]])))), # nolint: object_usage_linter
+              y_arg = rlang::expr_deparse(dplyr::expr(`$`(comp_value, !!sym(comp_nms[[comp_i]])))) # nolint: object_usage_linter
             ))),
             cli::format_message(c(
               ">" = "You likely want to rename or remove this column from your slide

man/key_colnames.Rd

@@ -8,14 +8,13 @@ test_that("canonical arrangement works", {
   expect_error(arrange_canonical(tib))
 
   tib <- tib %>% as_epi_df(other_keys = "demo_grp")
-  expect_equal(names(tib), c("geo_value", "time_value", "demo_grp", "x"))
+  expect_equal(names(tib), c("geo_value", "demo_grp", "time_value", "x"))
 
-  tib_cols_shuffled <- tib %>% select(geo_value, time_value, x, demo_grp)
-
-  tib_sorted <- arrange_canonical(tib_cols_shuffled)
-  expect_equal(names(tib_sorted), c("geo_value", "time_value", "demo_grp", "x"))
+  tib_sorted <- tib %>%
+    arrange_canonical()
+  expect_equal(names(tib_sorted), c("geo_value", "demo_grp", "time_value", "x"))
   expect_equal(tib_sorted$geo_value, rep(c("ca", "ga"), each = 4))
-  expect_equal(tib_sorted$time_value, c(1, 1, 2, 2, 1, 1, 2, 2))
-  expect_equal(tib_sorted$demo_grp, rep(letters[1:2], times = 4))
-  expect_equal(tib_sorted$x, c(8, 6, 7, 5, 4, 2, 3, 1))
+  expect_equal(tib_sorted$time_value, c(1, 2, 1, 2, 1, 2, 1, 2))
+  expect_equal(tib_sorted$demo_grp, c("a", "a", "b", "b", "a", "a", "b", "b"))
+  expect_equal(tib_sorted$x, c(8, 7, 6, 5, 4, 3, 2, 1))
 })

tests/testthat/test-arrange-canonical.R

@@ -53,7 +53,7 @@ get_test_dataset <- function(n, time_type = "day", other_keys = FALSE) {
   }
   df %>%
     arrange_canonical() %>%
-    group_epi_df()
+    group_epi_df(exclude = "time_value")
 }
 test_data <- get_test_dataset(num_rows_per_group, "day")
 
@@ -82,10 +82,10 @@ epi_slide_sum_test <- function(
 
   .x %>%
     mutate(.real = TRUE) %>%
-    group_epi_df() %>%
+    group_epi_df(exclude = "time_value") %>%
     complete(time_value = vctrs::vec_c(!!!date_seq_list, .name_spec = rlang::zap())) %>%
     arrange_canonical() %>%
-    group_epi_df() %>%
+    group_epi_df(exclude = "time_value") %>%
     mutate(
       slide_value = slider::slide_index_sum(
         .data$value,
@@ -246,7 +246,7 @@ for (p in (param_combinations %>% transpose())) {
         mutate(slide_value = list(slide_value)) %>%
         ungroup() %>%
         as_epi_df(as_of = attr(test_data, "metadata")$as_of, other_keys = attr(test_data, "metadata")$other_keys) %>%
-        group_epi_df()
+        group_epi_df(exclude = "time_value")
 
       expect_equal(
         out %>% select(-slide_value),
@@ -268,7 +268,7 @@ for (p in (param_combinations %>% transpose())) {
         mutate(slide_value = list(slide_value)) %>%
         ungroup() %>%
         as_epi_df(as_of = attr(test_data, "metadata")$as_of, other_keys = attr(test_data, "metadata")$other_keys) %>%
-        group_epi_df()
+        group_epi_df(exclude = "time_value")
       expect_equal(
         out %>% select(-slide_value),
         expected_out %>% select(-slide_value)

tests/testthat/test-epi_slide.R

@@ -69,21 +69,20 @@ test_that("Subsetting drops & does not drop the epi_df class appropriately", {
   expect_equal(ncol(col_subset2), 2L)
 
   # Row and col subset that contains geo_value and time_value - should be epi_df
-  row_col_subset2 <- toy_epi_df[2:3, 1:3]
+  row_col_subset2 <- toy_epi_df[2:3, c(1, 4)]
   att_row_col_subset2 <- attr(row_col_subset2, "metadata")
 
   expect_true(is_epi_df(row_col_subset2))
   expect_equal(nrow(row_col_subset2), 2L)
-  expect_equal(ncol(row_col_subset2), 3L)
+  expect_equal(ncol(row_col_subset2), 2L)
   expect_identical(att_row_col_subset2$geo_type, att_toy$geo_type)
   expect_identical(att_row_col_subset2$time_type, att_toy$time_type)
   expect_identical(att_row_col_subset2$as_of, att_toy$as_of)
-  expect_identical(att_row_col_subset2$other_keys, att_toy$other_keys[1])
 })
 
 test_that("When duplicate cols in subset should abort", {
   expect_error(toy_epi_df[, c(2, 2:3, 4, 4, 4)],
-    "Duplicated column names: time_value, indic_var2",
+    "Duplicated column names: indic_var1, time_value",
     fixed = TRUE
   )
   expect_error(toy_epi_df[1:4, c(1, 2:4, 1)],
@@ -94,7 +93,7 @@ test_that("When duplicate cols in subset should abort", {
 
 test_that("Correct metadata when subset includes some of other_keys", {
   # Only include other_var of indic_var1
-  only_indic_var1 <- toy_epi_df[, c(1:3, 5:6)]
+  only_indic_var1 <- toy_epi_df[, c(1:2, 4:6)]
   att_only_indic_var1 <- attr(only_indic_var1, "metadata")
 
   expect_true(is_epi_df(only_indic_var1))
@@ -106,7 +105,7 @@ test_that("Correct metadata when subset includes some of other_keys", {
   expect_identical(att_only_indic_var1$other_keys, att_toy$other_keys[-2])
 
   # Only include other_var of indic_var2
-  only_indic_var2 <- toy_epi_df[, c(1:2, 4:6)]
+  only_indic_var2 <- toy_epi_df[, c(1, 3:6)]
   att_only_indic_var2 <- attr(only_indic_var2, "metadata")
 
   expect_true(is_epi_df(only_indic_var2))