extractSMR:

- add support for SMR described only at subgroup level - add aquic ("sapr", "hem", "fibr") and peraquic ("wass") suborders
ncss-tech · Oct 1, 2024 · 481db77 · 481db77
1 parent dff0043
commit 481db77
Showing 1 changed file with 44 additions and 37 deletions.
diff --git a/R/extractSMR.R b/R/extractSMR.R
@@ -12,50 +12,57 @@
 #' @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",
+                           "udic", "ustic", "xeric"),
+               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[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) {
+      co$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)
-}