allo#72: Prefer expert over generic equations.

.buildignore/dbh-vs-biomass.md

@@ -4,6 +4,15 @@ Plot dbh vs. biomass by species
 ``` r
 # Setup
 library(tidyverse)
+#> -- Attaching packages --------------------------------------------- tidyverse 1.2.1 --
+#> v ggplot2 3.1.0       v purrr   0.3.1  
+#> v tibble  2.0.1       v dplyr   0.8.0.1
+#> v tidyr   0.8.3       v stringr 1.4.0  
+#> v readr   1.3.1       v forcats 0.4.0
+#> Warning: package 'purrr' was built under R version 3.5.3
+#> -- Conflicts ------------------------------------------------ tidyverse_conflicts() --
+#> x dplyr::filter() masks stats::filter()
+#> x dplyr::lag()    masks stats::lag()
 library(fgeo.biomass)
 ```
 
@@ -32,10 +41,11 @@ census_species <- census %>%
 
 census_equations <- allo_find(census_species)
 #> Assuming `dbh` in [mm] (required to find dbh-specific equations).
-#> * Searching equations according to site and species.
-#> Warning: Can't find equations matching these species:
-#> acer sp, carya sp, crataegus sp, fraxinus sp, juniperus virginiana, quercus prinus, quercus sp, ulmus sp, unidentified unk
+#> * Matching equations by site and species.
 #> * Refining equations according to dbh.
+#> * Using generic equations where expert equations can't be found.
+#> Warning:   Can't find equations matching these species:
+#>   acer sp, carya sp, crataegus sp, fraxinus sp, juniperus virginiana, quercus prinus, quercus sp, ulmus sp, unidentified unk
 #> Warning: Can't find equations for 17132 rows (inserting `NA`).
 ```
 

R/allo_find.R

@@ -3,18 +3,22 @@ allo_find_impl <- function(data, custom_eqn) {
     suppressMessages(fgeo.biomass::default_eqn(allodb::master_tidy()))
   abort_if_not_eqn(eqn)
 
-  inform("* Searching equations according to site and species.")
+  inform("* Matching equations by site and species.")
   .by <- c("sp", "site")
-  dbh_all <- dplyr::left_join(data, eqn, by = .by)
-  warn_if_species_missmatch(data, eqn)
+  matched <- dplyr::left_join(data, eqn, by = .by)
 
   inform("* Refining equations according to dbh.")
-  dbh_all$dbh_in_range <- is_in_range(
-    dbh_all$dbh, min = dbh_all$dbh_min_mm, max = dbh_all$dbh_max_mm
+  matched$dbh_in_range <- is_in_range(
+    matched$dbh, min = matched$dbh_min_mm, max = matched$dbh_max_mm
   )
-  in_range <- filter(dbh_all, .data$dbh_in_range)
-  out <- suppressMessages(dplyr::left_join(data, in_range))
-  out$dbh_in_range <- NULL
+  in_range <- filter(matched, .data$dbh_in_range)
+  refined <- suppressMessages(dplyr::left_join(data, in_range))
+  refined$dbh_in_range <- NULL
+
+  inform("* Using generic equations where expert equations can't be found.")
+  out <- prefer_expert_equaitons(refined)
+
+  warn_if_species_missmatch(out, eqn)
   warn_if_missing_equations(out)
 
   out
@@ -98,7 +102,7 @@ warn_if_species_missmatch <- function(data, eqn) {
     warn(glue("
       Can't find equations matching these species:
       {missmatching}
-      "))
+    "))
   }
 
   invisible(data)
@@ -114,3 +118,10 @@ warn_if_missing_equations <- function(data) {
 
   invisible(data)
 }
+
+prefer_expert_equaitons <- function(data) {
+  data %>%
+    group_by(.data$rowid) %>%
+    filter(replace_na(prefer_false(.data$is_generic), TRUE)) %>%
+    ungroup()
+}

R/default_eqn.R

@@ -52,7 +52,10 @@ modify_default_eqn <- function(out) {
       equation_allometry = NULL,
       anatomic_relevance = .data$dependent_variable_biomass_component,
       dbh_min_mm = measurements::conv_unit(.data$dbh_min_cm, "cm", to = "mm"),
-      dbh_max_mm = measurements::conv_unit(.data$dbh_max_cm, "cm", to = "mm")
+      dbh_max_mm = measurements::conv_unit(.data$dbh_max_cm, "cm", to = "mm"),
+      is_generic = dplyr::if_else(
+        tolower(.data$equation_group) == "generic", TRUE, FALSE
+      )
     ) %>%
     dplyr::rename(
       sp = .data$species,
@@ -102,7 +105,8 @@ crucial_equation_cols <- function() {
     "dbh_units_original",
     "biomass_units_original",
     "dbh_min_cm",
-    "dbh_max_cm"
+    "dbh_max_cm",
+    "equation_group"
   )
 }
 
@@ -117,6 +121,7 @@ output_cols <- function() {
     "dbh_unit",
     "bms_unit",
     "dbh_min_mm",
-    "dbh_max_mm"
+    "dbh_max_mm",
+    "is_generic"
   )
 }

R/utils.R

@@ -1,3 +1,17 @@
+prefer_false <- function(x) {
+  stopifnot(is.logical(x))
+  if (all(x[!is.na(x)])) {
+    x
+  } else {
+    !x
+  }
+}
+
+replace_na <- function(x, replacement) {
+  x[is.na(x)] <- replacement
+  x
+}
+
 is_in_range <- function(x, min, max) {
   x >= min & x <= max
 }

tests/testthat/test-allo_find.R

@@ -1,9 +1,30 @@
 context("allo_find")
 
 library(dplyr)
-
 set.seed(1)
 
+test_that("allo_find prefers expert over generic equations (allo#72)", {
+  cns_sp <- fgeo.biomass::scbi_tree1 %>%
+    dplyr::sample_n(1000) %>%
+    add_species(fgeo.biomass::scbi_species, "scbi")
+
+  some_generic_equations <- any(
+    as.vector(na.omit(
+      suppressWarnings(allo_find(cns_sp))$is_generic
+    ))
+  )
+  expect_true(some_generic_equations)
+
+  out <- allo_find(cns_sp)
+  pref <- out %>%
+    group_by(rowid) %>%
+    filter(
+        replace_na(prefer_false(is_generic), TRUE)
+      ) %>%
+    ungroup()
+  expect_equal(out, pref)
+})
+
 test_that("allo_find does not warn if dbh in [mm]", {
   data <- fgeo.biomass::scbi_tree1 %>%
     dplyr::sample_n(1000) %>%
@@ -32,7 +53,7 @@ test_that("allo_find warns non matching species", {
 
   expect_warning(
     allo_find(census_species),
-    "Can't find equations matching these species"
+    "Can't find.*equations matching these species"
   )
 })
 

tests/testthat/test-default_eqn.R

@@ -1,5 +1,12 @@
 context("default_eqn")
 
+test_that("default_eqn `is_generic` maps to equation_group == 'Generic'", {
+  expect_equal(
+    default_eqn(allodb::master_tidy())$is_generic,
+    tolower(allodb::master_tidy()$equation_group) == "generic"
+  )
+})
+
 test_that("defualt_eqn outputs dbh_min and dbh_max in [mm]", {
   data <- default_eqn(allodb::master_tidy())
 
@@ -23,7 +30,8 @@ test_that("default_eqn has expected columns", {
       "dbh_unit",
       "bms_unit",
       "dbh_min_mm",
-      "dbh_max_mm"
+      "dbh_max_mm",
+      "is_generic"
   )
   expect_named(default_eqn(allodb::master_tidy()), nms)
 })

tests/testthat/test-utils.R

@@ -1,3 +1,43 @@
+context("prefer_false")
+
+expect_equal(prefer_false(c(T, NA)), c(T, NA))
+expect_equal(prefer_false(c(F, NA)), c(T, NA))
+expect_equal(prefer_false(c(F, NA, T)), c(T, NA, F))
+
+expect_equal(
+  replace_na(
+    prefer_false(c(F, NA, T)),
+    TRUE
+  ),
+  c(T, T, F)
+)
+
+expect_equal(prefer_false(c(T)), c(T))
+expect_equal(prefer_false(c(F)), c(T))
+expect_equal(prefer_false(c(F, T)), c(T, F))
+expect_equal(prefer_false(c(T, T)), c(T, T))
+expect_equal(prefer_false(c(T, F, F)), c(F, T, T))
+
+dfm <- tibble::tribble(
+  ~id, ~lgl,
+  1,   TRUE,
+  1,   FALSE,
+  2,   FALSE,
+  3,   TRUE,
+)
+
+# Ungrouped
+out <- filter(dfm, prefer_false(lgl))
+expect_equal(out$id, c(1, 2))
+expect_equal(out$lgl, c(FALSE, FALSE))
+
+# Grouped
+out <- filter(group_by(dfm, id), prefer_false(lgl))
+expect_equal(out$id, c(1, 2, 3))
+expect_equal(out$lgl, c(FALSE, FALSE, TRUE))
+
+
+
 context("is_in_range")
 
 test_that("is_in_range returns true if in range, else returns false", {