Merge pull request #634 from cmu-delphi/lcb/address-dist_quantiles-deprecation

Address `dist_quantiles()` deprecation

Author: dajmcdon

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: epiprocess
 Title: Tools for basic signal processing in epidemiology
-Version: 0.11.0
+Version: 0.11.1
 Authors@R: c(
     person("Jacob", "Bien", role = "ctb"),
     person("Logan", "Brooks", , "lcbrooks+github@andrew.cmu.edu", role = c("aut", "cre")),
@@ -66,12 +66,13 @@ Suggests:
     distributional,
     epidatr,
     epipredict,
+    hardhat,
     here,
     knitr,
     outbreaks,
     readr,
     rmarkdown,
-    testthat (>= 3.1.5),
+    testthat,
     trendfilter,
     withr
 VignetteBuilder:

R/key_colnames.R

@@ -91,8 +91,8 @@ key_colnames.epi_df <- function(x, ...,
   if (!identical(other_keys, expected_other_keys)) {
     cli_abort(c(
       "The provided `other_keys` argument didn't match the `other_keys` of `x`",
-      "*" = "`other_keys` was {format_chr_with_quotes(other_keys)}",
-      "*" = "`expected_other_keys` was {format_chr_with_quotes(expected_other_keys)}",
+      "*" = "`other_keys` was {format_chr_deparse(other_keys)}",
+      "*" = "`expected_other_keys` was {format_chr_deparse(expected_other_keys)}",
       "i" = "If you know that `x` will always be an `epi_df` and
              resolve this discrepancy by adjusting the metadata of `x`, you
              shouldn't have to pass `other_keys =` here anymore,

R/methods-epi_archive.R

@@ -450,7 +450,8 @@ epix_merge <- function(x, y,
   y_nonby_colnames <- setdiff(names(y_dt), by)
   if (length(intersect(x_nonby_colnames, y_nonby_colnames)) != 0L) {
     cli_abort("
-            `x` and `y` DTs have overlapping non-by column names;
+            `x` and `y` DTs both have measurement columns named
+            {format_chr_with_quotes(intersect(x_nonby_colnames, y_nonby_colnames))};
             this is currently not supported; please manually fix up first:
             any overlapping columns that can are key-like should be
             incorporated into the key, and other columns should be renamed.

R/utils.R

@@ -98,26 +98,29 @@ format_chr_deparse <- function(x) {
   paste(collapse = "", deparse(x))
 }
 
-#' Format a character vector as a string via deparsing/quoting each
+#' Format each entry in a character vector via quoting; special replacement for length 0
+#'
+#' Performs no escaping within the strings; if you want something that reader
+#' could copy-paste to debug, look into `format_deparse` (note that this
+#' collapses into a single string).
+#'
+#' @param x chr; e.g., `colnames` of some data frame
+#' @param empty chr, likely string; what should be output if `x` is of length 0?
+#' @return chr; same `length` as `x` if `x` had nonzero length; value of `empty` otherwise
+#'
+#' @examples
+#' cli::cli_inform('{epiprocess:::format_chr_with_quotes("x")}')
+#' cli::cli_inform('{epiprocess:::format_chr_with_quotes(c("x","y"))}')
+#' nms <- c("x", "\"Total Cases\"")
+#' cli::cli_inform("{epiprocess:::format_chr_with_quotes(nms)}")
+#' cli::cli_inform("{epiprocess:::format_chr_with_quotes(character())}")
 #'
-#' @param x `chr`; e.g., `colnames` of some data frame
-#' @param empty string; what should be output if `x` is of length 0?
-#' @return string
 #' @keywords internal
 format_chr_with_quotes <- function(x, empty = "*none*") {
   if (length(x) == 0L) {
     empty
   } else {
-    # Deparse to get quoted + escape-sequenced versions of varnames; collapse to
-    # single line (assuming no newlines in `x`). Though if we hand this to cli
-    # it may insert them (even in middle of quotes) while wrapping lines.
-    deparsed_collapsed <- paste(collapse = "", deparse(x))
-    if (length(x) == 1L) {
-      deparsed_collapsed
-    } else {
-      # remove surrounding `c()`:
-      substr(deparsed_collapsed, 3L, nchar(deparsed_collapsed) - 1L)
-    }
+    paste0('"', x, '"')
   }
 }
 

man/format_chr_with_quotes.Rd

@@ -1,4 +1,6 @@
 library(testthat)
 library(epiprocess)
 
+stopifnot(packageVersion("testthat") >= "3.1.5")
+
 test_check("epiprocess")

tests/testthat.R

@@ -120,37 +120,54 @@ test_that("compactify does not alter the default clobberable and observed versio
   expect_identical(ea_true$versions_end, ea_false$versions_end)
 })
 
+quantile_pred_once <- function(estimates_vec, levels_vec) {
+  hardhat::quantile_pred(t(as.matrix(estimates_vec)), levels_vec)
+}
 test_that("compactify works on distributions", {
+  skip("Until #611 is merged or hardhat/epipredict is patched")
   forecasts <- tibble(
     ahead = 2L,
     geo_value = "ak",
     target_end_date = as.Date("2020-01-19"),
-    forecast_date = as.Date("2020-01-17") + 1:8,
+    forecast_date = as.Date("2020-01-17") + 1:6,
     actual = 25,
     .pred_distn = c(
-      epipredict::dist_quantiles(c(1, 5, 9), c(0.1, 0.5, 0.9)),
-      epipredict::dist_quantiles(c(1, NA, 9), c(0.1, 0.5, 0.9)), # single NA in quantiles
-      epipredict::dist_quantiles(c(NA, NA, NA), c(0.1, 0.5, 0.9)), # all NAs in quantiles
-      distributional::dist_missing(1), # the actual `NA` for distributions
-      epipredict::dist_quantiles(c(1, 5, 9), c(0.1, 0.5, 0.9)), # and back
-      epipredict::dist_quantiles(c(3, 5, 9), c(0.1, 0.5, 0.9)), # change quantile
-      epipredict::dist_quantiles(c(3, 5, 9), c(0.2, 0.5, 0.8)), # change level
-      epipredict::dist_quantiles(c(3, 5, 9), c(0.2, 0.5, 0.8)) # LOCF
+      quantile_pred_once(c(1, 5, 9), c(0.1, 0.5, 0.9)),
+      quantile_pred_once(c(1, NA, 9), c(0.1, 0.5, 0.9)), # single NA in quantiles
+      quantile_pred_once(c(NA, NA, NA), c(0.1, 0.5, 0.9)), # all NAs in quantiles
+      quantile_pred_once(c(1, 5, 9), c(0.1, 0.5, 0.9)), # and back
+      quantile_pred_once(c(3, 5, 9), c(0.1, 0.5, 0.9)), # change quantile
+      quantile_pred_once(c(3, 5, 9), c(0.1, 0.5, 0.9)) # LOCF
     )
   )
   expect_equal(
     forecasts %>%
-      as_epi_archive(
-        other_keys = "ahead", time_value = target_end_date, version = forecast_date,
-        compactify = TRUE
-      ) %>%
+      as_epi_archive(other_keys = "ahead", time_value = target_end_date, version = forecast_date) %>%
       .$DT %>%
       as.data.frame() %>%
       as_tibble(),
-    forecasts[-8, ] %>%
+    forecasts[-6, ] %>%
       rename(time_value = target_end_date, version = forecast_date)
   )
 })
+test_that("epix_merge works with distributions", {
+  skip("Until hardhat/epipredict is patched")
+  forecasts1ea <- tibble(
+    ahead = 2L,
+    geo_value = "ak",
+    target_end_date = as.Date("2020-01-19"),
+    forecast_date = as.Date("2020-01-17") + 1,
+    .pred_distn1 = quantile_pred_once(c(1, 5, 9), c(0.1, 0.5, 0.9))
+  ) %>% as_epi_archive(other_keys = "ahead", time_value = target_end_date, version = forecast_date)
+  forecasts2ea <- tibble(
+    ahead = 2L,
+    geo_value = "ak",
+    target_end_date = as.Date("2020-01-19"),
+    forecast_date = as.Date("2020-01-17") + 2,
+    .pred_distn2 = quantile_pred_once(c(2, 4, 8), c(0.1, 0.5, 0.9))
+  ) %>% as_epi_archive(other_keys = "ahead", time_value = target_end_date, version = forecast_date)
+  forecasts12ea <- epix_merge(forecasts1ea, forecasts2ea, sync = "locf")
+})
 
 test_that("Large compactify_abs_tol does not drop edf keys", {
   # several epikeytimes, each with a single version

tests/testthat/test-compactify.R

@@ -175,7 +175,7 @@ test_that("epix_merge forbids and warns on metadata and naming issues", {
       as_epi_archive(tibble::tibble(geo_value = "ak", time_value = test_date, version = test_date + 1L, value = 1L)),
       as_epi_archive(tibble::tibble(geo_value = "ak", time_value = test_date, version = test_date + 1L, value = 2L))
     ),
-    regexp = "overlapping.*names"
+    regexp = 'both have measurement columns named "value"'
   )
 })