Merge pull request #48 from ncss-tech/extractSubgroupSMR

extractSMR updates
ncss-tech · Oct 1, 2024 · 9b91ad2 · 9b91ad2
2 parents dff0043 + d2ab06e
commit 9b91ad2
Show file tree

Hide file tree

Showing 2 changed files with 57 additions and 46 deletions.
diff --git a/R/extractSMR.R b/R/extractSMR.R
@@ -12,50 +12,59 @@
 #' @examples
 #' extractSMR(c("aquic haploxeralfs", "typic epiaqualfs", "humic inceptic eutroperox"))
 extractSMR <- function(taxon, as.is = FALSE, droplevels = FALSE, ordered = TRUE) {
-  res <- vapply(taxon, .extractSMR, character(1))
+
+  .get_SMR_element_connotation <- function() {
+    data.frame(element = c("ids",
+                           "per", "aqu", "torr", "ud", "ust", "xer", "sapr", "hem", "fibr", "wass",
+                           "torri", "ud", "ust", "xer", "aqu",
+                           "ud", "ust", "xer"),
+               level = c("order",
+                         "suborder", "suborder", "suborder", "suborder", "suborder", "suborder", "suborder", "suborder", "suborder", "suborder",
+                         "greatgroup", "greatgroup", "greatgroup", "greatgroup", "greatgroup",
+                         "subgroup", "subgroup", "subgroup"),
+               connotation = c("aridic (torric)",
+                               "perudic", "aquic", "aridic (torric)", "udic", "ustic", "xeric", "aquic", "aquic", "aquic", "peraquic",
+                               "aridic (torric)", "udic", "ustic", "xeric", "aquic",
+                               "udic", "ustic", "xeric"),
+               stringsAsFactors = FALSE)
+  }
+
+  # get SMR formative element connotation LUT
+  co <-  .get_SMR_element_connotation()
+
+  res <- vapply(taxon, function(taxon) {
+
+    # extract formative elements
+    el <- FormativeElements(taxon)
+
+    # determine taxon level and position
+    el$defs$hierarchy <- level_hierarchy(el$defs$level)
+    th <- min(el$defs$hierarchy, na.rm = TRUE)
+
+    # only consider SMR formative elements at or below taxon level
+    el$defs <- el$defs[grepl(paste0(co$element, collapse = "|"), el$defs$element) & th <= el$defs$level, ]
+    maxlevel <- suppressWarnings(max(el$defs$hierarchy, na.rm = TRUE))
+    el$defs <- el$defs[el$defs$hierarchy == maxlevel, ]
+
+    # THEN get highest level taxon SMR connotation
+    co2 <- co[!is.na(pmatch(co$element, el$defs$element, duplicates.ok = TRUE)) &
+                co$level %in% el$defs$level &
+                co$level == maxlevel, ]
+    nrx <- nrow(co2)
+    if (nrx == 1) {
+      co2$connotation
+    } else NA_character_
+  }, character(1))
+
   if (as.is) {
     return(res)
   }
+
   res <- factor(res, levels = SoilMoistureRegimeLevels(as.is = TRUE), ordered = ordered)
   if (droplevels) {
     return(droplevels(res))
   }
+
   names(res) <- taxon
   res
 }
-
-.extractSMR <- function(taxon) {
-
-  # extract formative elements
-  el <- FormativeElements(taxon)
-
-  # determine taxon level and position
-  el$defs$hierarchy <- level_hierarchy(el$defs$level)
-  th <- min(el$defs$hierarchy, na.rm = TRUE)
-
-  # get SMR formative element connotation LUT
-  co <- .get_SMR_element_connotation()
-
-  # only consider SMR formative elements at or below taxon level
-  el$defs <- el$defs[el$defs$element %in% co$element & th <= el$defs$level,]
-
-  # THEN get highest level taxon SMR connotation
-  co <- co[co$element %in% el$defs$element &
-             co$level %in% el$defs$level &
-             co$level == suppressWarnings(max(el$defs$hierarchy, na.rm = TRUE)), ]
-  nrx <- nrow(co)
-  if (nrx == 1) {
-    # todo handle per+aqu and per+ud
-    co$connotation
-  } else NA_character_
-}
-
-.get_SMR_element_connotation <- function() {
-  # x <- get_ST_formative_elements()
-  # x[grepl("SMR|wetness", x$connotation) & x$level != "subgroup",][c("element","level")]
-  ## NB: currently there is no formative element connotation for "peraquic" soils
-  data.frame(element = c("per", "ids", "aqu", "torr", "ud", "ust", "xer", "torri", "ud", "ust", "xer", "aqu"),
-             level = c("suborder", "order", "suborder", "suborder", "suborder", "suborder", "suborder", "greatgroup", "greatgroup", "greatgroup", "greatgroup", "greatgroup"),
-             connotation = c("perudic", "aridic (torric)", "aquic", "aridic (torric)", "udic", "ustic", "xeric", "aridic (torric)", "udic", "ustic", "xeric", "aquic"),
-             stringsAsFactors = FALSE)
-}
diff --git a/tests/testthat/test-extractSMR.R b/tests/testthat/test-extractSMR.R
@@ -16,15 +16,17 @@ test_that("extractSMR works", {
                    `aquisalids` = "aridic (torric)",
                    `aquiturbels` = "aquic"
                  ),
-                 levels = c(
-                   "aridic (torric)",
-                   "ustic",
-                   "xeric",
-                   "udic",
-                   "perudic",
-                   "aquic",
-                   "peraquic"
-                 ),
+                 levels = SoilMoistureRegimeLevels(as.is = TRUE),
                  ordered = TRUE)
               )
+
+  expect_equal(extractSMR(c('xerollic glossocryalfs', 'ustic haplocambids')),
+               factor(
+                 c(
+                   `xerollic glossocryalfs` = "xeric",
+                   `ustic haplocambids` = "aridic (torric)"
+                 ),
+                 levels = SoilMoistureRegimeLevels(as.is = TRUE),
+                 ordered = TRUE
+               ))
 })