Merge pull request #337 from lekoenig/303-edit-rescale-chars

Edit rescaled columns and add unit tests
DOI-USGS · Mar 13, 2023 · 970ddf6 · 970ddf6
2 parents 18a13cc + 997549c
commit 970ddf6
Show file tree

Hide file tree

Showing 3 changed files with 50 additions and 5 deletions.
diff --git a/R/rescale_catchments.R b/R/rescale_catchments.R
@@ -6,7 +6,15 @@ rescale_characteristics <- function(vars, lookup_table) {
   cols_min <- vars$characteristic_id[vars$summary_statistic == "min"]
   cols_max <- vars$characteristic_id[vars$summary_statistic == "max"]
 
+  # adjust certain column names to use rescaled values for split catchments (if applicable)
+  if(!all(lookup_table$comid == lookup_table$member_comid)){
+    cols_area_wtd_mean <- paste0(cols_area_wtd_mean, "_rescaled")
+    cols_sum <- paste0(cols_sum, "_rescaled")
+  }
+
+  # adjust column names to include percent_nodata columns
   vars_nodata <- names(select(lookup_table, starts_with("percent_nodata")))
+  vars_nodata <- grep("[0-9]+$", vars_nodata, value = TRUE, invert = TRUE)
   if(length(vars_nodata) > 0) {
     cols_area_wtd_mean <- c(cols_area_wtd_mean, vars_nodata)
   }
@@ -24,7 +32,8 @@ rescale_characteristics <- function(vars, lookup_table) {
       across(any_of(cols_min), \(x) min(x, na.rm = TRUE), .names = "{col}_min"),
       across(any_of(cols_max), \(x) max(x, na.rm = TRUE), .names = "{col}_max")
     ) |>
-    ungroup()
+    ungroup() |>
+    rename_with(~gsub("_rescaled", "", .), contains("_rescaled"))
 }
 
 #' @description
@@ -38,7 +47,6 @@ rescale_characteristics <- function(vars, lookup_table) {
 #' "areasqkm." Used to retrieve adjusted catchment areas in the case of split
 #' catchments.
 #'
-#' @importFrom sf st_drop_geometry
 #' @importFrom dplyr mutate select right_join left_join filter rename bind_rows
 #' @noRd
 #'
@@ -212,7 +220,8 @@ rescale_catchment_characteristics <- function(vars, lookup_table,
 
   # rescale the nldi characteristics if needed (i.e., for split catchments)
   if(!all(lookup_table$comid == lookup_table$member_comid)){
-    lookup_table <- mutate(lookup_table, across(any_of(var_names), ~.x*.data$split_area_prop))
+    lookup_table <- mutate(lookup_table,
+                           across(any_of(var_names), ~.x*.data$split_area_prop, .names = "{col}_rescaled"))
   }
 
   return(rescale_characteristics(vars, lookup_table))

diff --git a/tests/testthat/data/rescale_data.rds b/tests/testthat/data/rescale_data.rds
diff --git a/tests/testthat/test_rescale_catchments.R b/tests/testthat/test_rescale_catchments.R
@@ -2,8 +2,8 @@
 test_that("rescale", {
   skip_on_cran()
 
-  vars <- data.frame(characteristic_id = c("CAT_EWT", "CAT_EWT", "CAT_EWT"),
-                     summary_statistic = c("area_weighted_mean", "min","sum"))
+  vars <- data.frame(characteristic_id = c("CAT_EWT", "CAT_EWT", "CAT_EWT", "CAT_EWT", "CAT_BASIN_AREA"),
+                     summary_statistic = c("area_weighted_mean", "min", "sum", "max", "sum"))
 
   # file_name <- "refactor_02.gpkg"
   # file_path <- file.path(tempdir(), file_name)
@@ -46,6 +46,42 @@ test_that("rescale", {
 
   expect_equal(rescale, rescale_2)
 
+  expect_equal(round(rescale$areasqkm_sum,0), round(rescale$CAT_BASIN_AREA_sum,0))
+
+  test_id1 <- 10012268
+  comids1 <- filter(d$lookup_table, id == test_id1)
+  vars_comids1 <- left_join(x = left_join(x = comids1,
+                                          y = filter(d$catchment_characteristic,
+                                                     comid %in% comids1$comid,
+                                                     characteristic_id == "CAT_EWT"),
+                                          by = "comid"),
+                            y = select(d$catchment_areas, c("member_comid","split_catchment_areasqkm","split_area_prop")),
+                            by = "member_comid")
+  vars_comids1 <- mutate(vars_comids1, area_rescaled = split_catchment_areasqkm*split_area_prop)
+  rescale_test1 <- filter(rescale, id == test_id1)
+  expect_equal(min(vars_comids1$characteristic_value),rescale_test1$CAT_EWT_min)
+  expect_equal(sum(vars_comids1$characteristic_value),rescale_test1$CAT_EWT_sum)
+  expect_equal(max(vars_comids1$characteristic_value),rescale_test1$CAT_EWT_max)
+  expect_equal(weighted.mean(vars_comids1$characteristic_value, vars_comids1$area_rescaled),
+               rescale_test1$CAT_EWT_area_wtd)
+
+  test_id2 <- 10024048
+  comids2 <- filter(d$lookup_table, id == test_id2)
+  vars_comids2 <- left_join(x = left_join(x = comids2,
+                                          y = filter(d$catchment_characteristic,
+                                                     comid %in% comids2$comid,
+                                                     characteristic_id == "CAT_EWT"),
+                                          by = "comid"),
+                            y = select(d$catchment_areas, c("member_comid","split_catchment_areasqkm","split_area_prop")),
+                            by = "member_comid")
+  vars_comids2 <- mutate(vars_comids2, area_rescaled = split_catchment_areasqkm*split_area_prop)
+  rescale_test2 <- filter(rescale, id == test_id2)
+  expect_equal(min(vars_comids2$characteristic_value),rescale_test2$CAT_EWT_min)
+  expect_equal(sum(vars_comids2$characteristic_value*vars_comids2$split_area_prop),rescale_test2$CAT_EWT_sum)
+  expect_equal(max(vars_comids2$characteristic_value),rescale_test2$CAT_EWT_max)
+  expect_equal(weighted.mean(vars_comids2$characteristic_value*vars_comids2$split_area_prop, vars_comids2$area_rescaled),
+               rescale_test2$CAT_EWT_area_wtd)
+
   borked <- dplyr::rename(d$lookup_table, borked = "member_comid")
 
   expect_error(rescale_catchment_characteristics(vars, borked, d$split_divides),