tests(epi_slide_opt): more + failing test for epi_slide_opt.epi_archive()

Author: brookslogan

tests/testthat/test-epi_slide_opt_archive.R

@@ -35,7 +35,7 @@ test_that("epi_slide_opt_archive_one_epikey works as expected", {
     ),
     tibble(
       version = 13, time_value = 8:10, value = c(9, 9, 10),
-      slide_value = frollmean(c(6, 7, 9, 9, 10),  3,  algo = "exact")[-(1:2)]
+      slide_value = frollmean(c(6, 7, 9, 9, 10), 3, algo = "exact")[-(1:2)]
     ),
     tibble(
       version = 14, time_value = 11:13, value = c(NA, 12, 13), slide_value = rep(NA_real_, 3L)
@@ -89,7 +89,6 @@ test_that("epi_slide_opt.epi_archive is not confused by unique(DT$version) unsor
 })
 
 test_that("epi_slide_opt.epi_archive is not confused by unique(DT$time_value) unsorted", {
-
   start_date <- as.Date("2020-01-01")
   tibble(
     geo_value = c(1, 1, 2, 2),
@@ -109,26 +108,85 @@ test_that("epi_slide_opt.epi_archive is not confused by unique(DT$time_value) un
       ) %>%
         as_epi_archive()
     )
-
 })
 
-test_that("epi_slide_opt.epi_archive is equivalent to epix_slide reconversion on example data", {
+test_that("epi_slide_opt.epi_archive gives expected results on example data", {
+  # vs. built-in case_rate_7d_av column:
+
+  case_death_rate_archive_time <- system.time(
+    case_death_rate_archive_result <- case_death_rate_archive %>%
+      {
+        as_tibble(as.data.frame(.$DT))
+      } %>%
+      select(-case_rate_7d_av) %>%
+      as_epi_archive() %>%
+      epi_slide_opt(case_rate, frollmean, algo = "exact", .window_size = 7, .suffix = "_{.n}d_av")
+  )
+
+  case_death_rate_archive_expected <- case_death_rate_archive %>%
+    {
+      as_tibble(as.data.frame(.$DT))
+    } %>%
+    relocate(case_rate_7d_av, .after = last_col()) %>%
+    as_epi_archive() # ensure compact
+
+    expect_equal(case_death_rate_archive_result, case_death_rate_archive_expected)
+
+    tbl_diff2(
+      case_death_rate_archive_expected$DT[geo_value == "ak" & time_value <= as.Date("2020-03-16")] %>%
+        as.data.frame() %>% as_tibble(),
+      case_death_rate_archive_result$DT[geo_value == "ak" & time_value <= as.Date("2020-03-16")] %>%
+        as.data.frame() %>% as_tibble(),
+      c("geo_value", "time_value", "version")
+    )
+
+    case_death_rate_archive_result$DT[geo_value == "ak" & time_value <= as.Date("2020-03-16")]
+
+    # case_death_rate_archive_result %>%
+    case_death_rate_archive_expected %>%
+      epix_as_of(as.Date("2020-11-01")) %>%
+      filter(geo_value == "ak", time_value <= as.Date("2020-03-16")) %>%
+      # filter(between(time_value, as.Date("2020-03-09"), as.Date("2020-03-15"))) %>%
+      mutate(d = c(NA, diff(case_rate_7d_av))) %>%
+      {}
 
-  case_death_rate_archive %>%
-    epi_slide_opt(case_rate, frollmean, .window_size = 7
-                  # , algo = "exact"
-                  ) %>%
-    .$DT %>%
-    as.data.frame() %>%
-    as_tibble() %>%
-    filter(!approx_equal(case_rate_7dav, case_rate_7d_av, 1e-6, TRUE)) %>%
-    dplyr::transmute(version, geo_value, time_value, case_rate_7dav, case_rate_7d_av,
-                     abs_diff = abs(case_rate_7dav - case_rate_7d_av)) %>%
-    {}
+    # vs. computing via epix_slide:
 
-    # TODO finish tests on example data sets
+    mini_case_death_rate_archive <- case_death_rate_archive %>%
+      {
+        as_tibble(as.data.frame(.$DT))
+      } %>%
+      filter(geo_value %in% head(unique(geo_value), 4L)) %>%
+      as_epi_archive()
 
-  })
+    mini_case_death_rate_archive_time_opt <- system.time(
+      mini_case_death_rate_archive_result <- mini_case_death_rate_archive %>%
+        epi_slide_opt(case_rate, frollmean, .window_size = 7)
+    )
+
+    mini_case_death_rate_archive_time_gen <- system.time(
+      mini_case_death_rate_archive_expected <- mini_case_death_rate_archive %>%
+        epix_slide(~ .x %>% epi_slide_opt(case_rate, frollmean, .window_size = 7)) %>%
+        select(names(mini_case_death_rate_archive$DT), everything()) %>%
+        as_epi_archive()
+    )
+
+    expect_equal(mini_case_death_rate_archive_result, mini_case_death_rate_archive_expected)
+
+    archive_cases_dv_subset_time_opt <- system.time(
+      archive_cases_dv_subset_result <- archive_cases_dv_subset %>%
+        epi_slide_opt(percent_cli, frollmean, .window_size = 7)
+    )
+
+    archive_cases_dv_subset_time_gen <- system.time(
+      archive_cases_dv_subset_expected <- archive_cases_dv_subset %>%
+        epix_slide(~ .x %>% epi_slide_opt(percent_cli, frollmean, .window_size = 7)) %>%
+        select(geo_value, time_value, version, everything()) %>%
+        as_epi_archive()
+    )
+
+    expect_equal(archive_cases_dv_subset_result, archive_cases_dv_subset_expected)
+})
 
 
 # TODO grouped behavior checks