Merge pull request #309 from ncss-tech/deprecateGuess

Deprecate 'guessing' functions for horizon-level column names
ncss-tech · Jun 25, 2024 · a98a409 · a98a409
2 parents a14ff26 + 9c3af4e
commit a98a409
Show file tree

Hide file tree

Showing 28 changed files with 314 additions and 209 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -175,6 +175,7 @@ exportMethods("horizons<-")
 exportMethods("hzID<-")
 exportMethods("hzdesgnname<-")
 exportMethods("hzidname<-")
+exportMethods("hzmetaname<-")
 exportMethods("hztexclname<-")
 exportMethods("initSpatial<-")
 exportMethods("metadata<-")
@@ -207,6 +208,7 @@ exportMethods(hzID)
 exportMethods(hzMetadata)
 exportMethods(hzdesgnname)
 exportMethods(hzidname)
+exportMethods(hzmetaname)
 exportMethods(hztexclname)
 exportMethods(idname)
 exportMethods(isEmpty)

diff --git a/R/SoilProfileCollection-metadata.R b/R/SoilProfileCollection-metadata.R
@@ -293,3 +293,74 @@ setReplaceMethod("GHL",
                      allowednames = "horizon"
                    )
                  })
+
+setGeneric("hzmetaname", function(object, attr, required = FALSE)
+  standardGeneric("hzmetaname"))
+
+#' @title Get or Set Horizon Metadata Column Name
+#' @name hzmetaname
+#' @aliases hzmetaname hzmetaname,SoilProfileCollection-method hzmetaname<- hzmetaname,SoilProfileCollection-method
+#' @details Store the column name containing a specific type of horizon data in the metadata slot of the SoilProfileCollection.
+#' @description `hzmetaname()`: Get column name containing horizon data of interest 
+#' @param object a SoilProfileCollection
+#' @param attr character. Base name for attribute to be stored in metadata. This is prefixed with `"aqp_hz"` for horizon-level metadata for column attributes. e.g. `attr="clay"` results in metadata value retrieved from `"aqp_hzclay"`.
+#' @param required logical, is this attribute required? If it is, set to `TRUE` to trigger error on invalid result
+#' @docType methods
+#' @rdname hzmetaname
+#' @export
+setMethod("hzmetaname", signature(object = "SoilProfileCollection"),
+          function(object, attr, required = FALSE) {
+            .require.metadata.aqp(object,
+                                  attr = paste0("aqp_hz", attr),
+                                  attrlabel = paste0("Horizon metadata (", attr, ") column"),
+                                  message = "\nSee ??hzmetaname",
+                                  required = required)
+          })
+
+setGeneric('hzmetaname<-', function(object, attr, required = FALSE, value)
+  standardGeneric('hzmetaname<-'))
+
+#' @description `hzmetaname<-`: Set horizon designation column name
+#' @param object A _SoilProfileCollection_
+#' @param attr _character_. Base name for attribute to be stored in metadata. This is prefixed with `"aqp_hz"` for horizon-level metadata for column attributes. e.g. `attr="clay"` results in metadata value retrieved from `"aqp_hzclay"`.
+#' @param value _character_. Name of horizon-level column containing  data corresponding to `attr`.
+#' @param required _logical_. Is this attribute required? If it is, set to `TRUE` to trigger error on invalid `value`.
+#' @docType methods
+#' @seealso [guessHzAttrName()]
+#' @rdname hzmetaname
+#' @export
+#' @examples
+#'
+#' data(sp1)
+#'
+#' # promote to SPC
+#' depths(sp1) <- id ~ top + bottom
+#'
+#' # set important metadata columns
+#' hzdesgnname(sp1) <- "name"
+#' hztexclname(sp1) <- "texture"
+#' 
+#' # set custom horizon property (clay content) column
+#' hzmetaname(sp1, "clay") <- "prop"
+#' 
+#' # inspect metadata list
+#' metadata(sp1)
+#'
+#' # get horizon clay content column
+#' hzmetaname(sp1, "clay")
+#' 
+#' # uses hzdesgname(), hztexclname(), hzmetaname(attr="clay") in function definition
+#' estimatePSCS(sp1)
+setReplaceMethod("hzmetaname",
+                 signature(object = "SoilProfileCollection"),
+                 function(object, attr, required = FALSE, value) {
+                   .set.metadata.aqp(
+                     object = object,
+                     value = value,
+                     required =  required,
+                     attr = paste0("aqp_hz", attr),
+                     attrlabel = paste0("Horizon metadata (", attr, ") column"),
+                     message = "\nSee ??hzmetaname",
+                     allowednames = "horizon"
+                   )
+                 })
diff --git a/R/allocate.R b/R/allocate.R
@@ -697,6 +697,11 @@ allocate <- function(..., to = c("FAO Salt Severity", "FAO Black Soil", "ST Diag
 #' 
 #' depths(h) <- id ~ top + bottom
 #' 
+#' # set required metadata for estimatePSCS()
+#' hzdesgnname(h) <- "hzname"
+#' hztexclname(h) <- "texcl"
+#' hzmetaname(h, "clay") <- "clay"
+#' 
 #' pscs <- data.frame(id = h$id, rbind(estimatePSCS(h)))
 #' names(pscs)[2:3] <- c("top", "bottom")
 #' 

diff --git a/R/depthOf.R b/R/depthOf.R
@@ -60,7 +60,7 @@ depthOf <- function(p,
                     pattern, 
                     FUN = NULL,
                     top = TRUE, 
-                    hzdesgn = guessHzDesgnName(p),
+                    hzdesgn = hzdesgnname(p, required = TRUE),
                     no.contact.depth = NULL, 
                     no.contact.assigned = NA_real_,
                     na.rm = TRUE,
@@ -89,14 +89,10 @@ depthOf <- function(p,
 
   id <- idname(p)
   hid <- hzidname(p)
-  hznames <- horizonNames(p)
 
   # if the user has not specified a column containing horizon designations
-  if (!hzdesgn %in% hznames) {
-    hzdesgn <- guessHzDesgnName(p, required = TRUE)
-    if (!hzdesgn %in% hznames) {
-      stop("depth estimation relies on a column containing horizon designations")
-    }
+  if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(p)) {
+    stop("Horizon designation column (", hzdesgn, ") does not exist.")
   }
 
   # get horizons matching designation pattern
@@ -167,7 +163,7 @@ depthOf <- function(p,
                         pattern,
                         FUN,
                         top = TRUE,
-                        hzdesgn = guessHzDesgnName(p),
+                        hzdesgn = hzdesgnname(p, required = TRUE),
                         no.contact.depth = NULL,
                         no.contact.assigned = NA,
                         na.rm = TRUE,
@@ -216,7 +212,7 @@ depthOf <- function(p,
 maxDepthOf <- function(p,
                        pattern,
                        top = TRUE,
-                       hzdesgn = guessHzDesgnName(p),
+                       hzdesgn = hzdesgnname(p, required = TRUE),
                        no.contact.depth = NULL,
                        no.contact.assigned = NA,
                        na.rm = TRUE,
@@ -241,7 +237,7 @@ maxDepthOf <- function(p,
 minDepthOf <- function(p,
                        pattern,
                        top = TRUE,
-                       hzdesgn = guessHzDesgnName(p),
+                       hzdesgn = hzdesgnname(p, required = TRUE),
                        no.contact.depth = NULL,
                        no.contact.assigned = NA,
                        na.rm = TRUE,

diff --git a/R/estimatePSCS.R b/R/estimatePSCS.R
@@ -48,39 +48,41 @@
 #' depths(sp1) <- id ~ top + bottom
 #' site(sp1) <- ~ group
 #'
-#' p <- sp1
-#' attr <- 'prop' # clay contents
-#' foo <- estimatePSCS(p, hzdesgn='name', clay.attr = attr, texcl.attr="texture")
-#' foo
-#'
-#'
-estimatePSCS = function(p, hzdesgn = "hzname", clay.attr = "clay",
-                        texcl.attr = "texcl", tax_order_field = "tax_order",
-                        bottom.pattern='Cr|R|Cd', simplify = TRUE, ...) {
+#' # set required metadata
+#' hzdesgnname(sp1) <- 'name'
+#' hztexclname(sp1) <- 'texture'
+#' hzmetaname(sp1, 'clay') <- 'prop'
+#' 
+#' x <- estimatePSCS(sp1)
+#' x
+estimatePSCS <- function(
+    p,
+    hzdesgn = hzdesgnname(p, required = TRUE),
+    clay.attr = hzmetaname(p, "clay", required = TRUE),
+    texcl.attr = hztexclname(p, required = TRUE),
+    tax_order_field = "tax_order",
+    bottom.pattern = 'Cr|R|Cd',
+    simplify = TRUE,
+    ...
+) {
 
   .LAST <- NULL
   hz.depths <- horizonDepths(p)
 
   attr.len <- unlist(lapply(c(hzdesgn, clay.attr, texcl.attr), length))
   if (any(attr.len > 1))
     stop("horizon designation, clay attribute or texture class attribute must have length 1")
-
-  if (is.null(hzdesgn) | (!hzdesgn %in% horizonNames(p))) {
-    hzdesgn <- guessHzDesgnName(p, required = TRUE)
-    if (hzdesgn == "")
-      stop("horizon designation column not correctly specified")
+
+  if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(p)) {
+    stop("Horizon designation column (", hzdesgn, ") does not exist.")
   }
-
-  if (is.null(clay.attr) | (!clay.attr %in% horizonNames(p))) {
-    clay.attr <- guessHzAttrName(p, attr = "clay", optional = c("total","_r"))
-    if (clay.attr == "")
-      stop("horizon clay content column not correctly specified")
+
+  if (is.null(texcl.attr) || !texcl.attr %in% horizonNames(p)) {
+    stop("Horizon texture class column (", texcl.attr, ") does not exist.")
   }
-
-  if (is.null(texcl.attr) | (!texcl.attr %in% horizonNames(p))) {
-    texcl.attr <- guessHzTexClName(p)
-    if (texcl.attr == "")
-      stop("horizon texture class column not correctly specified")
+
+  if (is.null(clay.attr) | (!clay.attr %in% horizonNames(p))) {
+    stop("Horizon clay content column (", clay.attr, ") does not exist.")
   }
 
   soildepth <- minDepthOf(p, hzdesgn = hzdesgn, pattern = bottom.pattern, simplify = FALSE)[[hz.depths[1]]]

diff --git a/R/getArgillicBounds.R b/R/getArgillicBounds.R
@@ -42,15 +42,18 @@
 #' depths(sp1) <- id ~ top + bottom
 #' site(sp1) <- ~ group
 #'
-#' p <- sp1
-#' attr <- 'prop' # clay contents
-#' foo <- getArgillicBounds(p, hzdesgn='name', clay.attr = attr, texcl.attr="texture")
-#' foo
+#' # set required metadata
+#' hzdesgnname(sp1) <- 'name'
+#' hztexclname(sp1) <- 'texture'
+#' hzmetaname(sp1, 'clay') <- 'prop'
+#' 
+#' x <- getArgillicBounds(sp1)
+#' x
 #'
 getArgillicBounds <- function(p,
-                              hzdesgn = 'hzname',
-                              clay.attr = 'clay',
-                              texcl.attr = 'texcl',
+                              hzdesgn = hzdesgnname(p, required = TRUE),
+                              clay.attr = hzmetaname(p, 'clay', required = TRUE),
+                              texcl.attr = hztexclname(p, required = TRUE),
                               require_t = TRUE,
                               bottom.pattern = "Cr|R|Cd",
                               lower.grad.pattern = "^[2-9]*B*CB*[^rtd]*[1-9]*$",
@@ -61,26 +64,18 @@ getArgillicBounds <- function(p,
   hz <- horizons(p)
   hzd <- horizonDepths(p)
 
-  # ease removal of attribute name arguments -- deprecate them later
-  # for now, just fix em if the defaults dont match the hzdesgn/texcl.attr
-  if (!hzdesgn %in% horizonNames(p)) {
-    hzdesgn <- guessHzDesgnName(p)
-    if (is.na(hzdesgn))
-      stop("horizon designation column not correctly specified")
+  if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(p)) {
+    stop("Horizon designation column (", hzdesgn, ") does not exist.")
   }
-
-  if (!clay.attr %in% horizonNames(p)) {
-    clay.attr <- guessHzAttrName(p, attr = "clay", optional = c("total","_r"))
-    if (is.na(clay.attr))
-      stop("horizon clay content column not correctly specified")
+
+  if (is.null(clay.attr) | (!clay.attr %in% horizonNames(p))) {
+    stop("Horizon clay content column (", texcl.attr, ") does not exist.")
   }
-
-  if (!texcl.attr %in% horizonNames(p)) {
-    texcl.attr <- guessHzTexClName(p)
-    if (is.na(texcl.attr))
-      stop("horizon texture class column not correctly specified")
+
+  if (is.null(texcl.attr) || !texcl.attr %in% horizonNames(p)) {
+    stop("Horizon texture class column (", texcl.attr, ") does not exist.")
   }
-
+  
   # get upper bound...
   mss <- getMineralSoilSurfaceDepth(p, hzdesgn = hzdesgn, simplify = FALSE)
   pld <- getPlowLayerDepth(p, hzdesgn = hzdesgn, simplify = FALSE)

diff --git a/R/getCambicBounds.R b/R/getCambicBounds.R
@@ -38,26 +38,33 @@
 #'
 #' # promote to SoilProfileCollection
 #' depths(spc) <- id ~ hzdept + hzdepb
+#' 
+#' # set required metadata
 #' hzdesgnname(spc) <- 'hzname'
 #' hztexclname(spc) <- 'texcl'
-#'
+#' hzmetaname(spc, 'clay') <- 'clay'
+#' 
 #' # print results in table
 #' getCambicBounds(spc)
 #'
 getCambicBounds <- function(p,
-                            hzdesgn = guessHzDesgnName(p, required = TRUE),
-                            texcl.attr = guessHzTexClName(p, required = TRUE),
-                            clay.attr = guessHzAttrName(p, attr = 'clay', c("total", "_r")),
+                            hzdesgn = hzdesgnname(p, required = TRUE),
+                            texcl.attr = hztexclname(p, required = TRUE),
+                            clay.attr = hzmetaname(p, "clay", required = TRUE),
                             argi_bounds = NULL,
                             d_value = "d_value",
                             m_value = "m_value",
                             m_chroma = "m_chroma", 
                             sandy.texture.pattern = "-S$|^S$|COS$|L[^V]FS$|[^L]VFS$|LS$|LFS$",
                             ...) {
 
-  # sacrafice to CRAN gods in the name of NSE
+  # sacrifice to CRAN gods in the name of NSE
   id <- NULL
 
+  if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(p)) {
+    stop("Horizon designation column (", hzdesgn, ") does not exist.")
+  }
+
   # construct data.frame result for no-cambic-found (NA)
   empty_frame <- data.frame(id = character(0),
                             cambic_id = numeric(0),

diff --git a/R/getSurfaceHorizonDepth.R b/R/getSurfaceHorizonDepth.R
@@ -8,7 +8,7 @@
 #'
 #' @param p a SoilProfileCollection
 #' @param pattern a regular expression pattern to match for all horizons to be considered part of the "surface".
-#' @param hzdesgn column name containing horizon designation. Default: \code{guessHzDesgnName(p, required = TRUE)}.
+#' @param hzdesgn column name containing horizon designation. Default: `hzdesgnname(p, required = TRUE)`.
 #' @param simplify logical. Return single profile results as vector (default: `TRUE`) or `data.frame` (`FALSE`)
 #' @return a numeric value corresponding to the bottom depth of the last horizon matching 'pattern' that is contiguous with other matching horizons up to the soil surface. If `length(p) > 1` then a _data.frame_ containing profile ID, horizon ID, top or bottom depths, horizon designation and pattern.
 #'
@@ -57,12 +57,12 @@
 #'
 getSurfaceHorizonDepth <- function(p,
                                    pattern,
-                                   hzdesgn = guessHzDesgnName(p),
+                                   hzdesgn = hzdesgnname(p, required = TRUE),
                                    simplify = TRUE) {
 
-  if (!hzdesgn[1] %in% horizonNames(p)) {
-    # error if no valid designation found or specified
-    hzdesgn <- guessHzDesgnName(p, required = TRUE)
+
+  if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(p)) {
+    stop("Horizon designation column (", hzdesgn, ") does not exist.")
   }
 
   hz <- data.table::as.data.table(horizons(p))
@@ -160,15 +160,20 @@ getSurfaceHorizonDepth <- function(p,
 
 #' @rdname getSurfaceHorizonDepth
 #' @export
-getMineralSoilSurfaceDepth <-  function(p, hzdesgn = guessHzDesgnName(p), pattern = "O", simplify = TRUE) {
-  #assumes OSM is given O designation;
-  #TODO: add support for lab-sampled organic measurements
-  #      keep organic horizons with andic soil properties
+getMineralSoilSurfaceDepth <-  function(p, hzdesgn = hzdesgnname(p, required = TRUE), pattern = "O", simplify = TRUE) {
+
+  if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(p)) {
+    stop("Horizon designation column (", hzdesgn, ") does not exist.")
+  }
+
+  # assumes OSM is given O horizon designation;
+  # TODO: add support for lab-sampled organic measurements
+  #       keep organic horizons with andic soil properties
   return(getSurfaceHorizonDepth(p, hzdesgn = hzdesgn, pattern = pattern, simplify = simplify))
 }
 
 #' @rdname getSurfaceHorizonDepth
 #' @export
-getPlowLayerDepth <- function(p, hzdesgn = guessHzDesgnName(p), pattern = "^Ap[^b]*", simplify = TRUE) {
+getPlowLayerDepth <- function(p, hzdesgn = hzdesgnname(p, required = TRUE), pattern = "^Ap[^b]*", simplify = TRUE) {
   return(getSurfaceHorizonDepth(p, hzdesgn = hzdesgn, pattern = pattern, simplify = simplify))
 }