compactify changes including adding a vignette

R/slide.R

@@ -84,7 +84,27 @@
 #'   tidy evaluation (first example, above), then the name for the new column is 
 #'   inferred from the given expression and overrides any name passed explicitly 
 #'   through the `new_col_name` argument.
-#' 
+#'   
+#' When `f` is a named function with arguments, if a tibble with an unnamed 
+#'   grouping variable is passed in as the method argument to `f`, include a 
+#'   parameter for the grouping-variable in `function()` just prior to 
+#'   specifying the method to prevent that from being overridden. For example:
+#'   ```
+#'   # Construct an tibble with an unnamed grouping variable
+#'   edf = bind_rows(tibble(geo_value = "ak", time_value = as.Date("2020-01-01") 
+#'             + 1:10, x1=1:10, y=1:10 + rnorm(10L))) %>% 
+#'     as_epi_df()
+#'   
+#'   # Now, include a row parameter for the grouping variable in the tibble, 
+#'   # which we denote as g, just prior to method = "qr"
+#'   # Note that if g was not included below, then the method = "qr" would be 
+#'   # overridden, as described above
+#'   edf %>%
+#'   group_by(geo_value) %>%
+#'   epi_slide(function(x, g, method="qr", ...) tibble(model=list(
+#'             lm(y ~ x1, x, method=method))), n=7L) 
+#'   ```
+#'   
 #' @importFrom lubridate days weeks
 #' @importFrom rlang .data .env !! enquo enquos sym
 #' @export
@@ -121,7 +141,7 @@ epi_slide = function(x, f, ..., n = 7, ref_time_values,
   # intersect with observed time values
   if (missing(ref_time_values)) {
     ref_time_values = unique(x$time_value)
-  }
+  } 
   else {
     ref_time_values = ref_time_values[ref_time_values %in%
                                       unique(x$time_value)] 
@@ -164,6 +184,10 @@ epi_slide = function(x, f, ..., n = 7, ref_time_values,
   time_range = range(unique(x$time_value))
   starts = in_range(ref_time_values - before_num, time_range)
   stops = in_range(ref_time_values + after_num, time_range)
+
+  if( length(starts) == 0 || length(stops) == 0 ) { 
+    Abort("The starting and/or stopping times for sliding are out of bounds with respect to the range of times in your data. Check your settings for ref_time_values and align (and before, if specified).")
+  }
 
   # Symbolize new column name
   new_col = sym(new_col_name)

tests/testthat/test-compactify.R

@@ -0,0 +1,84 @@
+library(epiprocess)
+library(data.table)
+library(dplyr)
+
+dt <- archive_cases_dv$DT
+test_that("Input for compactify must be NULL or a boolean", {
+  expect_error(as_epi_archive(dv_duplicated,compactify="no"))
+})
+
+dt <- filter(dt,geo_value == "ca")
+dt$percent_cli <- c(1:80)
+dt$case_rate <- c(1:80)
+
+row_replace <- function(row,x,y) {
+  dt[row,4] <- x
+  dt[row,5] <- y
+  dt
+}
+
+# Rows 1 should not be eliminated even if NA
+dt <- row_replace(1,NA,NA) # Not LOCF
+
+# NOTE! We are assuming that there are no NA's in geo_value, time_value,
+# and version. Even though compactify may erroneously remove the first row
+# if it has all NA's, we are not testing this behaviour for now as this dataset
+# has problems beyond the scope of this test
+
+# Rows 11 and 12 correspond to different time_values
+dt <- row_replace(12,11,11) # Not LOCF
+
+# Rows 20 and 21 only differ in version
+dt <- row_replace(21,20,20) # LOCF
+
+# Rows 21 and 22 only differ in version
+dt <- row_replace(22,20,20) # LOCF
+
+# Row 39 comprises the first NA's
+dt <-row_replace(39,NA,NA) # Not LOCF
+
+# Row 40 has two NA's, just like its lag, row 39
+dt <- row_replace(40,NA,NA) # LOCF
+
+# Row 62's values already exist in row 15, but row 15 is not a preceding row
+dt <- row_replace(62,15,15) # Not LOCF
+
+# Row 73 only has one value carried over
+dt <- row_replace(74,73,74) # Not LOCF
+
+dt_true <- as_tibble(as_epi_archive(dt,compactify=TRUE)$DT)
+dt_false <- as_tibble(as_epi_archive(dt,compactify=FALSE)$DT)
+dt_null <- as_tibble(as_epi_archive(dt,compactify=NULL)$DT)
+
+test_that("Warning for LOCF with compactify as NULL", {
+  expect_warning(as_epi_archive(dt,compactify=NULL))
+})
+
+test_that("No warning when there is no LOCF", {
+  expect_warning(as_epi_archive(dt[1:10,],compactify=NULL),NA)
+})
+
+test_that("LOCF values are ignored with compactify=FALSE", {
+  expect_identical(nrow(dt),nrow(dt_false))
+})
+
+test_that("LOCF values are taken out with compactify=TRUE", {
+  dt_test <- as_tibble(as_epi_archive(dt[-c(21,22,40),],compactify=FALSE)$DT)
+
+  expect_identical(dt_true,dt_null)
+  expect_identical(dt_null,dt_test)
+})
+
+test_that("as_of utilizes LOCF even after removal of LOCF values",{
+  ea_true <- as_epi_archive(dt,compactify=TRUE)
+  ea_false <- as_epi_archive(dt,compactify=FALSE)
+
+  epix_as_of(ea_true,max(ea_true$DT$version))
+
+  # Row 22, an LOCF row corresponding to the latest version, but for the
+  # date 2020-06-02, is omitted in ea_true
+  as_of_true  <- ea_true$as_of(max(ea_true$DT$version))
+  as_of_false <- ea_false$as_of(max(ea_false$DT$version))
+
+  expect_identical(as_of_true,as_of_false)
+})