feat+bugs: add epix_as_of_now()

* fix yearmonth in epix_as_of and epix_slide
\

Author: dshemetov

NAMESPACE

@@ -73,6 +73,7 @@ export(epi_slide_mean)
 export(epi_slide_opt)
 export(epi_slide_sum)
 export(epix_as_of)
+export(epix_as_of_now)
 export(epix_fill_through_version)
 export(epix_merge)
 export(epix_slide)
@@ -95,6 +96,7 @@ export(new_epi_df)
 export(relocate)
 export(rename)
 export(revision_summary)
+export(set_versions_end)
 export(slice)
 export(sum_groups_epi_df)
 export(time_column_names)
@@ -245,6 +247,7 @@ importFrom(tidyselect,eval_select)
 importFrom(tidyselect,starts_with)
 importFrom(tools,toTitleCase)
 importFrom(tsibble,as_tsibble)
+importFrom(tsibble,yearmonth)
 importFrom(utils,capture.output)
 importFrom(utils,tail)
 importFrom(vctrs,"vec_slice<-")

R/grouped_epi_archive.R

@@ -437,9 +437,13 @@ epix_slide.grouped_epi_archive <- function(
   out <- lapply(.versions, function(.version) {
     # Ungrouped as-of data; `epi_df` if `all_versions` is `FALSE`,
     # `epi_archive` if `all_versions` is `TRUE`:
+    min_time_value <- .version - .before
+    if (is.na(min_time_value)) {
+      min_time_value <- -Inf
+    }
     as_of_raw <- .x$private$ungrouped %>% epix_as_of(
       .version,
-      min_time_value = .version - .before,
+      min_time_value = min_time_value,
       all_versions = .all_versions
     )
 

R/methods-epi_archive.R

@@ -59,10 +59,9 @@
 #'
 #' @importFrom data.table between key
 #' @export
-epix_as_of <- function(x, version = NULL, min_time_value = -Inf, all_versions = FALSE,
+epix_as_of <- function(x, version, min_time_value = -Inf, all_versions = FALSE,
                        max_version = deprecated()) {
   assert_class(x, "epi_archive")
-  version <- version %||% x$versions_end
 
   if (lifecycle::is_present(max_version)) {
     lifecycle::deprecate_warn("0.8.1", "epix_as_of(max_version =)", "epix_as_of(version =)")
@@ -114,26 +113,79 @@ epix_as_of <- function(x, version = NULL, min_time_value = -Inf, all_versions =
   if (all_versions) {
     # epi_archive is copied into result, so we can modify result directly
     result <- epix_truncate_versions_after(x, version)
-    result$DT <- result$DT[time_value >= .min_time_value, ] # nolint: object_usage_linter
+    if (!identical(.min_time_value, -Inf)) {
+      # See below for why we need this branch.
+      result$DT <- result$DT[time_value >= .min_time_value, ] # nolint: object_usage_linter
+    }
     return(result)
   }
 
   # Make sure to use data.table ways of filtering and selecting
-  as_of_epi_df <- x$DT[time_value >= .min_time_value & version <= .version, ] %>% # nolint: object_usage_linter
-    unique(
-      by = c("geo_value", "time_value", other_keys),
-      fromLast = TRUE
-    ) %>%
+  as_of_epi_df <- if (identical(.min_time_value, -Inf)) {
+    # This branch is needed for `epix_as_of` to work with `yearmonth` time type
+    # to avoid time_value > .min_time_value, which is NA for `yearmonth`.
+    x$DT[version <= .version, ]
+  } else {
+    x$DT[time_value >= .min_time_value & version <= .version, ]
+  } # nolint: object_usage_linter
+  as_of_epi_df <- as_of_epi_df %>%
+    unique(by = c("geo_value", "time_value", other_keys), fromLast = TRUE) %>%
     tibble::as_tibble() %>%
     dplyr::select(-"version") %>%
-    as_epi_df(
-      as_of = version,
-      other_keys = other_keys
-    )
+    as_epi_df(as_of = .version, other_keys = other_keys)
 
   return(as_of_epi_df)
 }
 
+#' Get the latest snapshot from an `epi_archive` object, using
+#' the current time value for the time type.
+#'
+#' @param x An `epi_archive` object
+#' @return The latest snapshot from an `epi_archive` object
+#' @export
+epix_as_of_now <- function(x) {
+  current_time_value <- current_time_value(x)
+  x %>%
+    set_versions_end(current_time_value) %>%
+    epix_as_of(current_time_value)
+}
+
+#' Get the latest time value for an `epi_archive` object
+#'
+#' @param x An `epi_archive` object
+#' @return The latest time value for an `epi_archive` object
+#' @importFrom tsibble yearmonth
+#' @noRd
+#' @keywords internal
+current_time_value <- function(x) {
+  if (x$time_type == "day") {
+    Sys.Date()
+  } else if (x$time_type == "week") {
+    max(seq(from = max(x$DT$time_value), to = Sys.Date(), by = "week"))
+  } else if (x$time_type == "yearmonth") {
+    yearmonth(Sys.Date())
+  } else if (x$time_type == "integer") {
+    cli_abort("Unable to determine the latest time value for an integer time type. Use `epix_as_of` instead.")
+  } else {
+    cli_abort("Unsupported time type in column `{time_value_arg}`, with class {.code {class(time_value)}}.
+    Time-related functionality may have unexpected behavior.
+    ", class = "epiprocess__epix_as_of_now_unsupported_time_type")
+  }
+}
+
+#' Set the `versions_end` attribute of an `epi_archive` object
+#'
+#' An escape hatch for epix_as_of, which does not allow version >
+#' `$versions_end`.
+#'
+#' @param x An `epi_archive` object
+#' @param versions_end The new `versions_end` value
+#' @return An `epi_archive` object with the updated `versions_end` attribute
+#' @export
+set_versions_end <- function(x, versions_end) {
+  x$versions_end <- versions_end
+  x
+}
 
 #' Fill `epi_archive` unobserved history
 #'
@@ -880,10 +932,13 @@ epix_slide.epi_archive <- function(
 #' @noRd
 epix_slide_versions_default <- function(ea) {
   versions_with_updates <- c(ea$DT$version, ea$versions_end)
-  tidyr::full_seq(versions_with_updates, guess_period(versions_with_updates))
+  if (ea$time_type == "yearmonth") {
+    min(versions_with_updates) + seq(0, max(versions_with_updates) - min(versions_with_updates), by = 1)
+  } else {
+    tidyr::full_seq(versions_with_updates, guess_period(versions_with_updates))
+  }
 }
 
-
 #' Filter an `epi_archive` object to keep only older versions
 #'
 #' Generates a filtered `epi_archive` from an `epi_archive` object, keeping

man/epix_as_of.Rd

@@ -0,0 +1,8 @@
+# epix_as_of_now works as expected
+
+    Code
+      attr(df %>% as_epi_archive() %>% epix_as_of_now(), "metadata")$as_of
+    Condition
+      Error in `current_time_value()`:
+      ! Unable to determine the latest time value for an integer time type. Use `epix_as_of` instead.
+

man/epix_as_of_now.Rd

@@ -128,3 +128,46 @@ test_that("group_vars works as expected", {
     "geo_value"
   )
 })
+
+test_that("epix_as_of_now works as expected", {
+  local_mocked_bindings(
+    Sys.Date = function(...) {
+      as.Date("2020-06-08")
+    },
+    .package = "base"
+  )
+  expect_equal(
+    attr(ea2_data %>% as_epi_archive() %>% epix_as_of_now(), "metadata")$as_of,
+    as.Date("2020-06-08")
+  )
+  time_value <- as.Date("2020-06-01")
+  df <- dplyr::tribble(
+    ~geo_value, ~time_value, ~version, ~cases,
+    "ca", time_value, time_value, 1,
+    "ca", time_value + 7, time_value + 7, 2,
+  )
+  expect_equal(
+    attr(df %>% as_epi_archive() %>% epix_as_of_now(), "metadata")$as_of,
+    as.Date("2020-06-08")
+  )
+  time_value <- tsibble::yearmonth(as.Date("2020-06-01") - lubridate::month(1))
+  df <- dplyr::tribble(
+    ~geo_value, ~time_value, ~version, ~cases,
+    "ca", time_value, time_value, 1,
+    "ca", time_value + lubridate::month(1), time_value + lubridate::month(1), 2,
+  )
+  expect_equal(
+    attr(df %>% as_epi_archive() %>% epix_as_of_now(), "metadata")$as_of,
+    tsibble::yearmonth("2020-06")
+  )
+  time_value <- 202006
+  df <- dplyr::tribble(
+    ~geo_value, ~time_value, ~version, ~cases,
+    "ca", time_value, time_value, 1,
+    "ca", time_value + 7, time_value + 7, 2,
+  )
+  expect_snapshot(
+    error = TRUE,
+    attr(df %>% as_epi_archive() %>% epix_as_of_now(), "metadata")$as_of
+  )
+})