From 7be0b0b472d216bd66415a704829668e7fcb6588 Mon Sep 17 00:00:00 2001 From: "Andrew G. Brown" Date: Sat, 1 Aug 2020 14:57:57 -0700 Subject: [PATCH] adjust for hzdesgn+texcl @metadata; add tests for guessX functions #143 --- R/guessColumnNames.R | 84 +++++++++++++------------- R/soilColorIndices.R | 15 +---- tests/testthat/test-guessColumnNames.R | 56 +++++++++++++++++ 3 files changed, 98 insertions(+), 57 deletions(-) create mode 100644 tests/testthat/test-guessColumnNames.R diff --git a/R/guessColumnNames.R b/R/guessColumnNames.R index 5394bf1a1..cf64d127d 100644 --- a/R/guessColumnNames.R +++ b/R/guessColumnNames.R @@ -30,27 +30,27 @@ guessHzDesgnName <- function(x) { stop("x must be a SoilProfileCollection") } - if(length(hzdesgnname(x))) { - # ideally use metadata if it contains a value. if so, no message - name <- hzdesgnname(x) - } else { - # possible names include column names with name in the name - possible.name <- nm[grep('name', nm, ignore.case=TRUE)] + hzd <- hzdesgnname(x) + if (length(hzd) == 1) { + if (hzd != "") + return(hzd) + } - # use the first valid guess - if(length(possible.name) > 0) { - possible.name <- possible.name[1] - name <- possible.name + # possible names include column names with name in the name + possible.name <- nm[grep('name', nm, ignore.case=TRUE)] + + # use the first valid guess + if(length(possible.name) > 0) { + possible.name <- possible.name[1] + name <- possible.name + } else { + # hail mary + try.again <- guessHzAttrName(x, "desgn", c("hz"), verbose = FALSE) + if (!is.na(try.again)) { + name <- try.again } else { - # hail mary - try.again <- guessHzAttrName(x, "desgn", c("hz"), verbose = FALSE) - if(!is.na(try.again)) { - name <- possible.name - } else { - message('unable to guess column containing horizon designations') - } + message('unable to guess column containing horizon designations') } - #message(paste('guessing horizon designations are stored in `', name, '`', sep='')) } return(name) @@ -81,38 +81,36 @@ guessHzDesgnName <- function(x) { #' guessHzTexClName <- function(x) { nm <- horizonNames(x) - name <- NA - if(!inherits(x, 'SoilProfileCollection')) { + if (!inherits(x, 'SoilProfileCollection')) { stop("x must be a SoilProfileCollection") } - if(length(hztexclname(x))) { - # ideally use metadata if it contains a value. if so, no message + if (length(hztexclname(x)) == 1) { + # ideally use metadata if it contains a value name <- hztexclname(x) - } else { - # possible names include column names with name in the name - possible.name <- nm[grep('texcl', nm, ignore.case=TRUE)] - - # use the first valid guess matching texcl - if(length(possible.name) > 0) { - possible.name <- possible.name[1] - name <- possible.name - #message(paste('guessing horizon texture classes are stored in `', name, '`', sep='')) - } else { - # alternately, try for something called "texture" - possible.name <- nm[grep('texture', nm, ignore.case=TRUE)] - if(length(possible.name) > 0) { - possible.name <- possible.name[1] - name <- possible.name - message(paste('guessing horizon texture classes are stored in `', name, '`', sep='')) - } else { - message('unable to guess column containing horizon texture classes') - } - } + if(name != "") + return(name) } - return(name) + # possible names include column names with name in the name + possible.name1 <- nm[grep('texcl', nm, ignore.case = TRUE)] + + # use the first valid guess matching texcl + if (length(possible.name1) == 1) { + possible.name1 <- possible.name1[1] + return(possible.name1) + } + + # alternately, try for something called "texture" + possible.name2 <- nm[grep('texture', nm, ignore.case = TRUE)] + if (length(possible.name2) > 0) { + possible.name2 <- possible.name2[1] + return(possible.name2) + } else { + message('unable to guess column containing horizon texture classes') + } + return("") } #' Guess Arbitrary Horizon Column Name diff --git a/R/soilColorIndices.R b/R/soilColorIndices.R index 1757b260a..09286132d 100644 --- a/R/soilColorIndices.R +++ b/R/soilColorIndices.R @@ -144,21 +144,8 @@ thompson.bell.darkness <- function(p, name = NULL, pattern="^A", value="m_value" # 10.2136/sssaj1996.03615995006000060051x hz <- horizons(p) depthz <- horizonDepths(p) - nm <- names(hz) - - # TODO: this should be an internal function if (missing(name)) { - possible.name <- nm[grep("name", nm, ignore.case = TRUE)] - if (length(possible.name) > 0) { - possible.name <- possible.name[1] - name <- possible.name - message(paste("guessing horizon designations are stored in `", - name, "`", sep = "")) - } - else { - message("unable to guess column containing horizon designations") - name <- NA - } + name <- guessHzDesgnName(p) } a.hz <- hz[grepl(hz[[name]], pattern = pattern),] diff --git a/tests/testthat/test-guessColumnNames.R b/tests/testthat/test-guessColumnNames.R new file mode 100644 index 000000000..a8fbf7675 --- /dev/null +++ b/tests/testthat/test-guessColumnNames.R @@ -0,0 +1,56 @@ +context("SoilProfileCollection attribute guessing functions") + +## sample data +data(sp3, package = 'aqp') +depths(sp3) <- id ~ top + bottom + +## tests +test_that("basic functionality", { + + # historic horizon designation name (e.g. used by plotSPC) + expect_equal(guessHzDesgnName(sp3), "name") + + # basic attribute name guessing + expect_message(expect_equal(guessHzAttrName(sp3, "clay", ""), "clay"), + "guessing horizon attribute 'clay' is stored in `clay`") + + # more complex attribute name guessing + sp3$clay_r <- sp3$clay + sp3$claytotal_r <- sp3$clay + + expect_message(expect_equal(guessHzAttrName(sp3, "clay", ""), "clay"), + "guessing horizon attribute 'clay' is stored in `clay`") + + expect_message(expect_equal(guessHzAttrName(sp3, "clay", c("_r", "total")), "claytotal_r"), + "guessing horizon attribute 'clay' is stored in `claytotal_r`") + + # basic attribute name guessing + expect_equal(guessHzTexClName(sp3), "") + + # texcl + horizons(sp3)$texcl <- "l" + expect_equal(guessHzTexClName(sp3), "texcl") + + # texture + horizons(sp3)$texture <- horizons(sp3)$texcl + horizons(sp3)$texcl <- NULL + expect_equal(guessHzTexClName(sp3), "texture") + + # descriptive name + sp3$hzdesgn <- sp3$name + sp3$name <- NULL + sp3$desgn <- 1:nrow(sp3) + expect_equal(guessHzDesgnName(sp3), "hzdesgn") + + # unable to guess name + sp3$foo <- sp3$hzdesgn + sp3$hzdesgn <- NULL + sp3$desgn <- NULL + expect_message(expect_equal(guessHzDesgnName(sp3), NA), + "unable to guess column containing horizon designations") + + # custom name + hzdesgnname(sp3) <- "foo" + expect_equal(guessHzDesgnName(sp3), "foo") +}) +