diff --git a/R/extractSMR.R b/R/extractSMR.R index 3226c30..67f0fe9 100644 --- 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 index 1dc2f5d..c13a74d 100644 --- 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 + )) })