Merge pull request #283 from ncss-tech/sieveCoarseFraction

`sieve()` for classifying arbitrary coarse fractions

NAMESPACE

@@ -49,6 +49,7 @@ export(explainPlotSPC)
 export(fillHzGaps)
 export(findOverlap)
 export(fixOverlap)
+export(fragmentClasses)
 export(fragvol_to_texmod)
 export(genSlabLabels)
 export(generalize.hz)
@@ -125,6 +126,7 @@ export(rgb2munsell)
 export(rxnclass_to_ph)
 export(segment)
 export(shannonEntropy)
+export(sieve)
 export(sim)
 export(simulateColor)
 export(slab_function)

NEWS.md

@@ -17,6 +17,7 @@ Notable changes include:
  * fast prototyping of SPCs via `quickSPC()` and list / character templates
  * re-use arguments to `plotSPC()` via `options(.aqp.plotSPC.args = list(...))`
 
+
 Incremental changes, should have no effect on previous code:
  * `plotSPC()` gains argument `maxLabelAdjustmentIndex` for controlling horizon depth label collisions
  * bug fix in `plotSPC()` when `fixLabelCollisions = TRUE`, adjustments suggested to `fixOverlap()` are now scaled correctly

R/fragmentClasses.R

@@ -0,0 +1,157 @@
+
+
+#' @title Coarse Fragment Class Labels and Diameter
+#' @description This is a convenience function for accessing coarse fragment class labels and associated diameter (mm), as defined in various classification systems such as USDA, Unified, and AASHTO.
+#'
+#' @param sys character, length 1. This is an abbreviated name used to select class labels and fragment diameter.
+#' @param flat logical. Fragments are flat, only used by USDA systems.
+#' @param rounded logical. Fragments are rounded, only used by AASHTO system.
+#' 
+#' @references 
+#' Schoeneberger, P.J., D.A. Wysocki, E.C. Benham, and Soil Survey Staff. 2012. Field book for describing and sampling soils, Version 3.0. Natural Resources Conservation Service, National Soil Survey Center, Lincoln, NE.
+#' 
+#' @return named vector of fragment diameter in mm
+#' @export
+#' 
+#' @seealso [sieve()]
+#'
+#' @examples
+#' 
+#' # use default system: "usda_simplified"
+#' fragmentClasses()
+#' fragmentClasses(flat = TRUE)
+#' 
+#' fragmentClasses(sys = 'usda')
+#' fragmentClasses(sys = 'USDA', flat = TRUE)
+#' 
+#' fragmentClasses(sys = 'international')
+#' 
+#' fragmentClasses(sys = 'unified')
+#' 
+#' fragmentClasses(sys = 'aashto')
+#' fragmentClasses(sys = 'aashto', rounded = TRUE)
+#' 
+#' fragmentClasses(sys = 'mod.wentworth')
+#' 
+fragmentClasses <- function(sys = c('usda_simplified', 'usda', 'international', 'unified', 'aashto', 'mod.wentworth'), flat = FALSE, rounded = FALSE) {
+
+  # normalize to lower case
+  sys <- tolower(sys)
+
+  # most frequent option, usually not specified
+  if(missing(sys)) {
+    sys <- 'usda_simplified'
+  } else {
+    sys <- match.arg(sys)
+  }
+
+  # upper fragment diameter, some large number (mm)
+  .upper_limit <- 1e5
+
+  # select a specification 
+  .spec <- switch(sys, 
+                  'usda_simplified' = {
+
+                    if(flat) {
+                      c(
+                        channers = 150,
+                        flagstones = 380,
+                        stones = 600,
+                        boulders = .upper_limit
+                      )
+
+                    } else {
+                      c(
+                        gravel = 76,
+                        cobbles = 250,
+                        stones = 600,
+                        boulders = .upper_limit
+                      )
+                    }
+
+                  },
+
+                  'usda' = {
+
+                    if(flat) {
+                      c(
+                        channers = 150,
+                        flagstones = 380,
+                        stones = 600,
+                        boulders = .upper_limit
+                      )
+
+                    } else {
+                      c(
+                        fine_gravel = 5,
+                        medium_gravel = 20,
+                        coarse_gravel = 76,
+                        cobbles = 250,
+                        stones = 600,
+                        boulders = .upper_limit
+                      )
+                    }
+
+                  },
+
+                  'international' = {
+
+                    c(
+                      gravel = 20,
+                      stones = .upper_limit
+                    )
+
+                  },
+
+                  'unified' = {
+
+                    c(
+                      fine_gravel = 19,
+                      coarse_gravel = 76,
+                      cobbles = 300,
+                      boulders = .upper_limit
+                    )
+
+                  },
+
+                  'aashto' = {
+
+                    if(rounded) {
+                      c(
+                        fine_gravel = 9.5,
+                        medium_gravel = 25,
+                        coarse_gravel = 75,
+                        boulders = .upper_limit
+                      )
+
+                    } else {
+                      c(
+                        fine_gravel = 9.5,
+                        medium_gravel = 25,
+                        coarse_gravel = 75,
+                        broken_rock = .upper_limit
+                      )
+                    }
+
+                  },
+
+                  'mod.wentworth' = {
+
+                    c(
+                      pebbles = 64,
+                      cobbles = 256,
+                      boulders = .upper_limit
+                    )
+
+                  }
+
+  )
+
+
+  return(.spec)
+}
+
+
+
+
+

R/sieve.R

@@ -0,0 +1,109 @@
+#' @title Sieve the Coarse Fraction of Soil
+#' 
+#' @description Sieve applies thresholds to a numeric vector of fragment diameter values, returning fragment size classes. Particle diameter thresholds are evaluated as `d < threshold`.
+#' 
+#' @references 
+#' 
+#' Soil Science Division Staff. 2017. Soil survey manual. C. Ditzler, K. Scheffe, and H.C. Monger (eds.). USDA Handbook 18. Government Printing Office, Washington, D.C.
+#' 
+#' @param diameter numeric. Vector of diameters of coarse fragments to "sieve". Default `sieves` are specified in millimeters.
+#' 
+#' @param sieves leave as `NULL` to use fragment class labels and diameters defined by [fragmentClasses()], or a named vector of fragment diameters. See examples.
+#' 
+#' @param ordered logical. Return as an ordered factor.
+#' 
+#' @param prefix character. Add a prefix to result names? Default: `""` adds no prefix. For example `"para"` might be used for size classes of pararock fragments.
+#' 
+#' @param new_names Optional: apply new labels to result classes. Should match length of `sieves`. 
+#' 
+#' @param ... additional arguments to [fragmentClasses()], such as `sys`, `flat`, and `rounded`, see examples.
+#'
+#' @return character. Size class labels based on names of `sieves`, `new_names`, and `prefix` (if specified).
+#' 
+#' @seealso [fragmentClasses()]
+#' 
+#' @export
+#'
+#' @examples
+#' 
+#' # use a simplified version of the USDA system
+#' # common within NRCS/SPSD and NCSS
+#' sieve(c(30, 125, 180, 500, 1000))
+#' 
+#' # pararock fragments
+#' sieve(c(30, 125, 180, 500, 1000), prefix = 'para')
+#' 
+#' # result as an ordered factor
+#' sieve(c(30, 125, 180, 500, 1000), ordered = TRUE)
+#' 
+#' # USDA system, flat size classes
+#' sieve(c(30, 125, 180, 500, 1000), flat = TRUE)
+#' 
+#' # alternative classification systems
+#' sieve(c(30, 125, 180, 500, 1000), sys = 'usda')
+#' sieve(c(30, 125, 180, 500, 1000), sys = 'international')
+#' sieve(c(30, 125, 180, 500, 1000), sys = 'unified')
+#' sieve(c(30, 125, 180, 500, 1000), sys = 'aashto')
+#' sieve(c(30, 125, 180, 500, 1000), sys = 'mod.wentworth')
+#' 
+#' # custom fragment labels / diameter
+#' sieve(
+#' c(30, 125, 180, 500, 1000), 
+#' sieves = c(clumps = 50, chunks = 300, blocks = 100000)
+#' )
+#' 
+#' # unnamed sieves, generic labels used
+#' sieve(c(10, 50), sieves = c(30, 70))
+#' 
+#' sieve(c(10, 50), sieves = c(30, 70), ordered = TRUE)
+#'  
+sieve <- function(diameter,
+                  sieves = NULL, 
+                  ordered = FALSE,
+                  prefix = "",
+                  new_names = NULL, 
+                  ...) {
+
+
+  # if not specified as named vector of diameters
+  # use fragmentClasses() to lookup one of several systems
+  if(is.null(sieves)) {
+    sieves <- fragmentClasses(...)
+  }
+
+  if (!is.null(new_names)) {
+    names(sieves) <- new_names
+  }
+
+  # test for NA, and filter-out
+  res <- vector(mode = 'character', length = length(diameter))
+  res[which(is.na(diameter))] <- NA
+  no.na.idx <- which(!is.na(diameter))
+
+  # only assign classes to non-NA diameters
+  if (length(no.na.idx) > 0) {
+    # pass diameters "through" sieves
+    # 2020: latest part 618 uses '<' for all upper values of class range
+    # 2022: adjusted gravel upper threshold to 76 mm 
+    classes <- t(sapply(diameter[no.na.idx], function(i) i < sieves))
+
+    if (length(names(sieves)) == 0) {
+      names(sieves) <- paste0("class_", seq_along(sieves))
+    }
+
+    # determine largest passing sieve name
+    res[no.na.idx] <- names(sieves)[apply(classes, 1, which.max)]
+
+    # apply prefix if specified, e.g. parafrags
+    if (nchar(prefix) > 0) {
+      res[no.na.idx] <- paste0(prefix, res[no.na.idx])
+    }
+  }
+
+  # optional conversion to ordered factor
+  if(ordered) {
+    res <- factor(res, levels = names(sieves), ordered = TRUE)
+  }
+
+  return(res)
+}