better lagyr sufficient data checking for anlz_fibmatrix

tbep-tech · Oct 15, 2024 · f77959f · f77959f
1 parent 424b211
commit f77959f
Show file tree

Hide file tree

Showing 2 changed files with 44 additions and 16 deletions.
diff --git a/R/anlz_fibmatrix.R b/R/anlz_fibmatrix.R
@@ -56,7 +56,7 @@ anlz_fibmatrix <- function(fibdata, yrrng = NULL, stas = NULL, bay_segment = NUL
                            precipdata = NULL, temporal_window = NULL, wet_threshold = NULL,
                            warn = TRUE){
 
-  geomean <- function(x){prod(x)^(1/length(x))}
+  geomean <- function(x){prod(x, na.rm = T)^(1/length(na.omit(x)))}
 
   subset_wetdry <- match.arg(subset_wetdry)
   indic <- match.arg(indic, c('fcolif', 'entero'))
@@ -207,11 +207,27 @@ anlz_fibmatrix <- function(fibdata, yrrng = NULL, stas = NULL, bay_segment = NUL
     dplyr::filter(station %in% stas) %>%
     dplyr::filter(yr >= (yrrng[1] - (lagyr - 1)) & yr <= yrrng[2]) %>%
     dplyr::filter(!is.na(indic) | indic < 0) %>%
+    tidyr::complete(
+      yr = tidyr::full_seq(c(min(yr) - (lagyr - 1), yr), 1),
+      tidyr::nesting(station)
+    ) %>%
     dplyr::summarise(
-      nyrs = length(unique(yr)),
-      .by = 'station'
+      hasdat = sum(any(!is.na(indic))),
+      .by = c('station', 'yr')
+    ) %>%
+    arrange(station, yr) %>%
+    dplyr::mutate(
+      chkyr = stats::filter(hasdat, rep(1, lagyr), sides = 1, method = 'convolution'),
+      .by = station
     ) %>%
-    dplyr::filter(nyrs >= lagyr) %>%
+    dplyr::filter(any(chkyr >= lagyr), .by = station)
+
+  # check if all stations invalid for lagyr
+  if(nrow(stasval) == 0){
+    stop('Insufficient data for lagyr')
+  }
+
+  stasval <- stasval %>%
     dplyr::pull(station) %>%
     unique()
 
@@ -224,11 +240,6 @@ anlz_fibmatrix <- function(fibdata, yrrng = NULL, stas = NULL, bay_segment = NUL
     stas <- stas[!chk]
   }
 
-  # check if all stations invalid for lagyr
-  if(sum(chk) == length(chk)){
-    stop('Insufficient data for lagyr')
-  }
-
   grp <- 'station'
   levs <- stas
   if(!is.null(bay_segment)){
@@ -243,6 +254,10 @@ anlz_fibmatrix <- function(fibdata, yrrng = NULL, stas = NULL, bay_segment = NUL
     dplyr::filter(yr >= (yrrng[1] - (lagyr - 1)) & yr <= yrrng[2]) %>%
     dplyr::filter(!is.na(indic) | indic < 0) %>%
     dplyr::rename(grp = !!grp) %>%
+    tidyr::complete(
+      yr = tidyr::full_seq(yr, 1),
+      tidyr::nesting(grp)
+    ) %>%
     summarise(
       gmean = geomean(indic),
       sumgt = sum(indic > thrsh),

diff --git a/tests/testthat/test-anlz_fibmatrix.R b/tests/testthat/test-anlz_fibmatrix.R
@@ -20,13 +20,26 @@ test_that("Checking anlz_fibmatrix station error all insufficient data", {
 
 # Example data
 fibdatatst <- data.frame(
-  yr = rep(2000:2005, each = 3),
-  epchc_station = rep(letters[1:3], times = 6),
-  fcolif = runif(18, 0, 500),
-  entero = runif(18, 0, 200),
-  Latitude = runif(18, 27, 28),
-  Longitude = runif(18, -82, -81)
-)
+  epchc_station = c('a', 'b', 'c'),
+  Latitude = runif(3, 27, 28),
+  Longitude = runif(3, -82, -81),
+  area = 'FL'
+  ) %>%
+  tidyr::crossing(
+    yr = rep(2000:2005),
+    mo = rep(1:12)
+  ) %>%
+  mutate(
+    fcolif = runif(n(), 0, 500),
+    entero = runif(n(), 0, 200)
+  )
+
+test_that("Checking anlz_fibmatrix station warning for insufficient data", {
+  datchk <- fibdatatst %>%
+    filter(!(epchc_station == 'a' & yr %in% c(2000:2003)))
+  expect_warning(anlz_fibmatrix(datchk, indic = 'fcolif', stas = c('a', 'b', 'c')), regexp = 'Stations with insufficient data for lagyr: a',
+               fixed = T)
+})
 
 test_that("anlz_fibmatrix returns correct structure", {
   result <- anlz_fibmatrix(fibdatatst, indic = 'fcolif', stas = c("a", "b", "c"))