diff --git a/R/extractSMR.R b/R/extractSMR.R index 9baea80..a97c4c9 100644 --- a/R/extractSMR.R +++ b/R/extractSMR.R @@ -12,57 +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() { - ## 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", "udic", "ustic", "xeric", - "aquic"), - level = c("suborder", "order", "suborder", "suborder", "suborder", - "suborder", "suborder", "greatgroup", "greatgroup", "greatgroup", - "greatgroup", "greatgroup", "subgroup", "subgroup", "subgroup", - "subgroup"), - connotation = c("perudic", "aridic (torric)", "aquic", "aridic (torric)", "udic", - "ustic", "xeric", "aridic (torric)", "udic", "ustic", - "xeric", "aquic", "udic", "ustic", "xeric", - "aquic"), - stringsAsFactors = FALSE) -}