adjust for hzdesgn+texcl @metadata; add tests for guessX functions #143

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

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),]

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")
+})
+