Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Deprecate 'guessing' functions for horizon-level column names #309

Merged
merged 6 commits into from
Jun 25, 2024
Merged
Show file tree
Hide file tree
Changes from 5 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -175,6 +175,7 @@ exportMethods("horizons<-")
exportMethods("hzID<-")
exportMethods("hzdesgnname<-")
exportMethods("hzidname<-")
exportMethods("hzmetaname<-")
exportMethods("hztexclname<-")
exportMethods("initSpatial<-")
exportMethods("metadata<-")
Expand Down Expand Up @@ -207,6 +208,7 @@ exportMethods(hzID)
exportMethods(hzMetadata)
exportMethods(hzdesgnname)
exportMethods(hzidname)
exportMethods(hzmetaname)
exportMethods(hztexclname)
exportMethods(idname)
exportMethods(isEmpty)
Expand Down
71 changes: 71 additions & 0 deletions R/SoilProfileCollection-metadata.R
Original file line number Diff line number Diff line change
Expand Up @@ -293,3 +293,74 @@ setReplaceMethod("GHL",
allowednames = "horizon"
)
})

brownag marked this conversation as resolved.
Show resolved Hide resolved
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"
)
})
16 changes: 6 additions & 10 deletions R/depthOf.R
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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,
Expand All @@ -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,
Expand Down
50 changes: 26 additions & 24 deletions R/estimatePSCS.R
Original file line number Diff line number Diff line change
Expand Up @@ -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]]]
Expand Down
43 changes: 19 additions & 24 deletions R/getArgillicBounds.R
Original file line number Diff line number Diff line change
Expand Up @@ -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]*$",
Expand All @@ -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)
Expand Down
17 changes: 12 additions & 5 deletions R/getCambicBounds.R
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand Down
25 changes: 15 additions & 10 deletions R/getSurfaceHorizonDepth.R
Original file line number Diff line number Diff line change
Expand Up @@ -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.
#'
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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))
}
Loading
Loading