diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index f2aec811b..a2bc6140f 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -34,10 +34,9 @@ jobs: R_REMOTES_NO_ERRORS_FROM_WARNINGS: true RSPM: ${{ matrix.config.rspm }} GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - + steps: - - uses: actions/checkout@v4 - + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} @@ -52,15 +51,8 @@ jobs: brew install --cask xquartz - uses: r-lib/actions/setup-r-dependencies@v2 - if: matrix.config.r == '3.6' with: - extra-packages: any::rcmdcheck, soiltexture=?ignore-before-r=4.3.0, markovchain=?ignore-before-r=4.0.0, Hmisc=?ignore - needs: check - - - uses: r-lib/actions/setup-r-dependencies@v2 - if: matrix.config.r != '3.6' - with: - extra-packages: any::rcmdcheck, markovchain=?ignore-before-r=4.0.0 + extra-packages: any::rcmdcheck, soiltexture=?ignore-before-r=4.3.0, sf=?ignore-before-r=4.0.0, markovchain=?ignore-before-r=4.0.0, Hmisc=?ignore, knitr=?ignore-before-r=4.0.0, rmarkdown=?ignore-before-r=4.0.0, testthat=?ignore-before-r=4.0.0, needs: check - name: Install soilDB from r-universe (R-devel only) @@ -70,6 +62,14 @@ jobs: shell: Rscript {0} - uses: r-lib/actions/check-r-package@v2 + if: matrix.config.r != '3.6' + with: + upload-snapshots: true + + - uses: r-lib/actions/check-r-package@v2 + if: matrix.config.r == '3.6' with: + args: 'c("--no-manual", "--as-cran", "--ignore-vignettes", "--no-tests")' + build_args: 'c("--no-manual", "--no-build-vignettes")' upload-snapshots: true diff --git a/CITATION.cff b/CITATION.cff index 197e64701..e83b2b488 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -19,7 +19,7 @@ abstract: The Algorithms for Quantitative Pedology (AQP) project was started in the scientist to focus on ideas rather than boilerplate data processing tasks . These functions and data structures have been extensively tested and documented, applied to projects involving hundreds of thousands of soil profiles, and deeply - integrated into widely used tools such as SoilWeb . + integrated into widely used tools such as SoilWeb . Components of the AQP project (aqp, soilDB, sharpshootR, soilReports packages) serve an important role in routine data analysis within the USDA-NRCS Soil Science Division. The AQP suite of R packages offer a convenient platform for bridging the gap between diff --git a/DESCRIPTION b/DESCRIPTION index 165ece2a5..89f400de6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,13 +1,13 @@ Package: aqp -Version: 2.0.3 +Version: 2.0.4 Title: Algorithms for Quantitative Pedology Authors@R: c(person(given="Dylan", family="Beaudette", role = c("aut", "cre"), email = "dylan.beaudette@usda.gov"), person(given="Pierre", family="Roudier", email="roudierp@landcareresearch.co.nz", role = c("aut", "ctb")), person(given="Andrew", family="Brown", email="andrew.g.brown@usda.gov", role = c("aut", "ctb"))) Author: Dylan Beaudette [aut, cre], Pierre Roudier [aut, ctb], Andrew Brown [aut, ctb] Maintainer: Dylan Beaudette Depends: R (>= 3.5.0) Imports: grDevices, graphics, stats, utils, methods, grid, lattice, cluster, sp, stringr, data.table, farver -Suggests: colorspace, ape, soilDB, sf, latticeExtra, tactile, compositions, sharpshootR, markovchain, xtable, testthat, Gmedian, Hmisc, tibble, RColorBrewer, scales, digest, MASS, mpspline2, soiltexture, gower, knitr, rmarkdown, plyr -Description: The Algorithms for Quantitative Pedology (AQP) project was started in 2009 to organize a loosely-related set of concepts and source code on the topic of soil profile visualization, aggregation, and classification into this package (aqp). Over the past 8 years, the project has grown into a suite of related R packages that enhance and simplify the quantitative analysis of soil profile data. Central to the AQP project is a new vocabulary of specialized functions and data structures that can accommodate the inherent complexity of soil profile information; freeing the scientist to focus on ideas rather than boilerplate data processing tasks . These functions and data structures have been extensively tested and documented, applied to projects involving hundreds of thousands of soil profiles, and deeply integrated into widely used tools such as SoilWeb . Components of the AQP project (aqp, soilDB, sharpshootR, soilReports packages) serve an important role in routine data analysis within the USDA-NRCS Soil Science Division. The AQP suite of R packages offer a convenient platform for bridging the gap between pedometric theory and practice. +Suggests: mvtnorm, colorspace, ape, soilDB, sf, latticeExtra, tactile, compositions, sharpshootR, markovchain, xtable, testthat, Gmedian, Hmisc, tibble, RColorBrewer, scales, digest, MASS, mpspline2, soiltexture, gower, knitr, rmarkdown, plyr +Description: The Algorithms for Quantitative Pedology (AQP) project was started in 2009 to organize a loosely-related set of concepts and source code on the topic of soil profile visualization, aggregation, and classification into this package (aqp). Over the past 8 years, the project has grown into a suite of related R packages that enhance and simplify the quantitative analysis of soil profile data. Central to the AQP project is a new vocabulary of specialized functions and data structures that can accommodate the inherent complexity of soil profile information; freeing the scientist to focus on ideas rather than boilerplate data processing tasks . These functions and data structures have been extensively tested and documented, applied to projects involving hundreds of thousands of soil profiles, and deeply integrated into widely used tools such as SoilWeb . Components of the AQP project (aqp, soilDB, sharpshootR, soilReports packages) serve an important role in routine data analysis within the USDA-NRCS Soil Science Division. The AQP suite of R packages offer a convenient platform for bridging the gap between pedometric theory and practice. License: GPL (>= 3) LazyLoad: yes Repository: CRAN @@ -15,6 +15,6 @@ URL: https://github.com/ncss-tech/aqp, https://ncss-tech.github.io/AQP/ BugReports: https://github.com/ncss-tech/aqp/issues Language: en-US Encoding: UTF-8 -RoxygenNote: 7.3.0 +RoxygenNote: 7.3.2 Roxygen: list(markdown = TRUE) VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 8e148c846..07e979be6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -95,7 +95,13 @@ export(hzOffset) export(hzTopographyCodeToLineType) export(hzTopographyCodeToOffset) export(hzTransitionProbabilities) +export(hz_dissolve) +export(hz_intersect) +export(hz_lag) +export(hz_segment) +export(hz_to_taxpartsize) export(invertLabelColor) +export(lookup_taxpartsize) export(lunique) export(maxDepthOf) export(minDepthOf) @@ -138,6 +144,7 @@ export(slice.fast) export(slicedHSD) export(soilColorSignature) export(soilPalette) +export(soilTextureColorPal) export(spc_in_sync) export(spec2Munsell) export(splitLogicErrors) @@ -151,6 +158,7 @@ export(texmod_to_fragvoltot) export(textureTriangleSummary) export(texture_to_taxpartsize) export(texture_to_texmod) +export(thicknessOf) export(thompson.bell.darkness) export(unroll) export(warpHorizons) @@ -168,6 +176,7 @@ exportMethods("horizons<-") exportMethods("hzID<-") exportMethods("hzdesgnname<-") exportMethods("hzidname<-") +exportMethods("hzmetaname<-") exportMethods("hztexclname<-") exportMethods("initSpatial<-") exportMethods("metadata<-") @@ -200,6 +209,7 @@ exportMethods(hzID) exportMethods(hzMetadata) exportMethods(hzdesgnname) exportMethods(hzidname) +exportMethods(hzmetaname) exportMethods(hztexclname) exportMethods(idname) exportMethods(isEmpty) @@ -310,6 +320,7 @@ importFrom(stats,as.dist) importFrom(stats,as.formula) importFrom(stats,cmdscale) importFrom(stats,complete.cases) +importFrom(stats,cov) importFrom(stats,dist) importFrom(stats,formula) importFrom(stats,median) diff --git a/NEWS.md b/NEWS.md index d81e9166c..0c3d9f376 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,18 @@ -# aqp 2.0.3 (2023-12-19) - * performance improvements in `profileInformationIndex()` +# aqp 2.0.4 (2024-10-10) + * CRAN release + * ragged bottom lines in `plotSPC()` now adjusted as function of number of profiles and device width + * additional metadata from `plotSPC()` saved to `last_spc_plot` in `aqp.env` + * added Munsell values of 8.5 and 9.5 to Munsell LUT and (interpolated) reference spectra (#318) + * `munsell2rgb()` now safely selects the closest Munsell value and chroma to those available in the package LUT + * new function `soilTextureColorPal()` for suggesting a color palette suitable for soil texture class + +# aqp 2.0.3 (2024-04-18) + * CRAN release + * `simulateColor()` gains new method `mvnorm` for simulating plausible colors + - package mvtnorm added to SUGGESTS + * performance improvements in `profileInformationIndex()`, `dice()`, `slab()`, `spc2mpspline()`, `fillHzGaps()`, and `flagOverlappingHz()` * aesthetic improvements in `huePositionCircle()` + * new function `thicknessOf()` used for calculating thickness of horizons within each profile of a `SoilProfileCollection` based on horizon-level logical expressions encoded in a function. Default behavior uses pattern matching on the horizon designation name. # aqp 2.0.2 (2023-11-18) * CRAN release @@ -598,7 +610,7 @@ Incremental changes, should have no effect on previous code: # aqp 1.0 (2012-03-26) * 1.0 release, still missing condensed vignettes- should be ready soon - * see http://casoilresource.lawr.ucdavis.edu/drupal/taxonomy/term/56 for samples + * see https://casoilresource.lawr.ucdavis.edu/drupal/taxonomy/term/56 for samples * A small bug in profile_compare() was fixed, where slices were evaluated as 'soil' based on the bottom depth of the profile, and NOT on the presence of actual data. See ?profile_compare for details. This change will have a minor affect on profile comparisons in cases where Cr or R horizons (usually missing most characterization data) have been extended down to some arbitrary depth (usually 150 or 200 cm) AND a maximum depth of evaluation (max_d) was set beyond the actual depth of most profiles in the collection. # aqp 0.99-9.8 (2012-03-02) diff --git a/R/Class-SoilProfileCollection.R b/R/Class-SoilProfileCollection.R index f4f6a9e14..4ea830da4 100644 --- a/R/Class-SoilProfileCollection.R +++ b/R/Class-SoilProfileCollection.R @@ -200,16 +200,9 @@ setClass( aqp_hzdesgn = "", aqp_hztexcl = "", depth_units = 'cm', - stringsAsFactors = FALSE, - - # calculate data order (original) - original.order = order(as.character(horizons[[idcol]]), - horizons[[depthcols[1]]]) + stringsAsFactors = FALSE ) - # the target order to check/maintain is the default for a new SPC - # metadata$target.order <- metadata$original.order - # add any custom metadata metadata <- c(metadata, new.metadata[!names(new.metadata) %in% names(metadata)]) @@ -955,10 +948,12 @@ setMethod("site", signature(object = "SoilProfileCollection"), setGeneric("diagnostic_hz", function(object, ...) standardGeneric("diagnostic_hz")) -#' Retrieve diagnostic data from SoilProfileCollection -#' -#' @description Get diagnostic feature data from SoilProfileCollection. Result is returned in the same \code{data.frame} class used to initially construct the SoilProfileCollection. +#' Get or Set Diagnostic Horizon data in a SoilProfileCollection #' +#' @description Diagnostic horizons describe features of the soil relevant to taxonomic classification. A single profile may have multiple diagnostic features or horizons, each of which may be comprised of multiple horizons. +#' +#' - `diagnostic_hz()` (get method): Get diagnostic feature data from a SoilProfileCollection. +#' #' @param object a SoilProfileCollection #' #' @docType methods @@ -975,9 +970,11 @@ setMethod(f = 'diagnostic_hz', signature(object = 'SoilProfileCollection'), setGeneric("restrictions", function(object, ...) standardGeneric("restrictions")) -#' Retrieve restriction data from SoilProfileCollection +#' Get or Set Restriction data in a SoilProfileCollection #' -#' @description Get restriction data from SoilProfileCollection. Result is returned in the same \code{data.frame} class used to initially construct the SoilProfileCollection. +#' @description Restrictions describe root-limiting features in the soil. A single profile may have multiple restrictions. +#' +#' - `restrictions()` (get method): Get restriction data from a SoilProfileCollection. #' #' @param object a SoilProfileCollection #' @docType methods diff --git a/R/L1_profiles.R b/R/L1_profiles.R index ca64e0709..b77930eb1 100644 --- a/R/L1_profiles.R +++ b/R/L1_profiles.R @@ -86,9 +86,9 @@ L1_profiles <- function(x, fm, basis = 1, method = c('regex', 'simple', 'constant'), maxDepthRule = c('max', 'min'), maxDepthConstant = NULL) { # sanity check, need this for L1 median - if(!requireNamespace('Gmedian')) - stop('package `Gmedian` is required', call.=FALSE) - + if(!requireNamespace('Gmedian')) { + stop('package `Gmedian` is required', call. = FALSE) + } # sanity checks: is this an SPC? if(! inherits(x, 'SoilProfileCollection')) { diff --git a/R/SoilProfileCollection-integrity.R b/R/SoilProfileCollection-integrity.R index b009e4197..05cfab936 100644 --- a/R/SoilProfileCollection-integrity.R +++ b/R/SoilProfileCollection-integrity.R @@ -94,10 +94,7 @@ setMethod('reorderHorizons', h <- object@horizons - if (is.null(target.order)) - target.order <- metadata(object)$original.order - if (is.null(target.order)) - target.order <- 1:nrow(h) + stopifnot(!is.null(target.order)) current.order <- match(target.order, order(as.character(h[[idname(object)]]), diff --git a/R/SoilProfileCollection-metadata.R b/R/SoilProfileCollection-metadata.R index f32ae9ef4..7d834cb33 100644 --- a/R/SoilProfileCollection-metadata.R +++ b/R/SoilProfileCollection-metadata.R @@ -73,7 +73,9 @@ customattr <- customattr[!names(customattr) %in% names(attributes(SoilProfileCollection()))] attributes(dest)[names(customattr)] <- attributes(src)[names(customattr)] + # original.order metadata no longer created, not transferred cols <- names(m)[names(m) != "original.order"] + metadata(dest)[cols] <- m[cols] dest } @@ -291,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" + ) + }) \ No newline at end of file diff --git a/R/SoilProfileCollection-setters.R b/R/SoilProfileCollection-setters.R index 82442a28e..f05bc454d 100644 --- a/R/SoilProfileCollection-setters.R +++ b/R/SoilProfileCollection-setters.R @@ -544,9 +544,10 @@ setReplaceMethod("horizons", signature(object = "SoilProfileCollection"), if (!inherits(value, "data.frame")) stop("new horizon data input value must inherit from data.frame", call. = FALSE) - # allow short-circuit - if (all(colnames(value) %in% horizonNames(object)) & - all(c(idn, hdn, hzd) %in% colnames(value)) & + # allow short-circuit (handles NULL and non-op without going thru merge()) + if ((all(horizonNames(object) %in% colnames(value)) || + all(colnames(value) %in% horizonNames(object))) && + all(c(idn, hdn, hzd) %in% colnames(value)) && nrow(value) == nrow(object)) { if (!all(value[[idn]] %in% profile_id(object))) { message("Some profile IDs in input data are not present in object and no new columns to merge. Doing nothing.") @@ -628,19 +629,19 @@ setReplaceMethod("horizons", signature(object = "SoilProfileCollection"), setGeneric('diagnostic_hz<-', function(object, value) standardGeneric('diagnostic_hz<-')) -#' Add Data to Diagnostic Features Slot -#' #' @name diagnostic_hz<- #' -#' @description Diagnostic feature data in an object inheriting from \code{data.frame} can easily be added via merge (LEFT JOIN). There must be one or more same-named columns containing profile ID on the left and right hand side to facilitate the join: \code{diagnostic_hz(spc) <- newdata} -#' +#' @description +#' +#' - `diagnostic_hz<-` (set method): Set diagnostic feature data for a SoilProfileCollection. The profile ID column from `object` (`idname(object)`) must be present in the replacement `value` object. +#' #' @param object A SoilProfileCollection -#' @param value An object inheriting \code{data.frame} +#' @param value An object inheriting from \code{data.frame} #' #' @aliases diagnostic_hz<-,SoilProfileCollection-method #' @docType methods #' @export -#' @rdname diagnostic_hz-set +#' @rdname diagnostic_hz #' #' @examples #' @@ -682,26 +683,29 @@ setReplaceMethod("diagnostic_hz", # test for the special case where internally-used functions # are copying over data from one object to another, and diagnostic_hz(obj) is a 0-row data.frame # short-circut, and return original object - if(nrow(d) == 0 & nrow(value) == 0) + if (nrow(d) == 0 && nrow(value) == 0) return(object) # test to make sure that our common ID is present in the new data - if(! idn %in% nm) - stop(paste("diagnostic horizon data are missing pedon ID column: ", idn), call.=FALSE) - - # test to make sure that at least one of the IDS in candidate data are present within SPC - if(all( ! unique(value[[idn]]) %in% pIDs) ) - warning('candidate diagnostic horizon data have NO matching IDs in target SoilProfileCollection object!', call. = FALSE) + if (!idn %in% nm) + stop(paste("diagnostic horizon data are missing pedon ID column: ", idn), call. = FALSE) + uidm <- unique(value[[idn]]) %in% pIDs # warn user if some of the IDs in the candidate data are missing - if(any( ! unique(value[[idn]]) %in% pIDs) ) { - warning('some records in candidate diagnostic horizon data have no matching IDs in target SoilProfileCollection object') + if (any(!uidm)) { + # test to make sure that at least one of the IDS in candidate data are present within SPC + if (all(!uidm)) { + warning('candidate diagnostic horizon data have NO matching IDs in target SoilProfileCollection object!', call. = FALSE) + } else warning('some records in candidate diagnostic horizon data have no matching IDs in target SoilProfileCollection object', call. = FALSE) } # if data are already present, warn the user - if(nrow(d) > 0) - warning('overwriting existing diagnostic horizon data!', call.=FALSE) - + if (nrow(d) > 0) + warning('overwriting existing diagnostic horizon data!', call. = FALSE) + + # convert id column to character to match @site + value[[idn]] <- as.character(value[[idn]]) + # copy data over object@diagnostic <- .as.data.frame.aqp(value, metadata(object)$aqp_df_class) @@ -712,19 +716,18 @@ setReplaceMethod("diagnostic_hz", setGeneric('restrictions<-', function(object, value) standardGeneric('restrictions<-')) -#' Add Data to Restrictions Slot -#' #' @name restrictions<- #' -#' @description Restrictions data in an object inheriting from \code{data.frame} can easily be added via merge (LEFT JOIN). There must be one or more same-named profile ID columns on the left and right hand side to facilitate the join: \code{restrictions(spc) <- newdata}. -#' +#' @description +#' +#' - `restrictions<-` (set method): Set restriction data for a SoilProfileCollection. The profile ID column from `object` (`idname(object)`) must be present in the replacement `value` object. #' @param object A SoilProfileCollection -#' @param value An object inheriting \code{data.frame} +#' @param value An data.frame object containing at least a column with name `idname(object)` #' #' @aliases restrictions<-,SoilProfileCollection-method #' @docType methods #' -#' @rdname restrictions-set +#' @rdname restrictions #' @export #' @examples #' @@ -759,31 +762,35 @@ setReplaceMethod("restrictions", signature(object = "SoilProfileCollection"), # testing the class of the new data if (!inherits(value, "data.frame")) - stop("restriction data must be a data.frame", call.=FALSE) + stop("restriction data must be a data.frame", call. = FALSE) # test for the special case where internally-used functions # are copying over data from one object to another, and diagnostic_hz(obj) is a 0-row data.frame # short-circuit, and return original object - if(nrow(d) == 0 & nrow(value) == 0) + if (nrow(d) == 0 && nrow(value) == 0) return(object) # test to make sure that our common ID is present in the new data - if(! idn %in% nm) - stop(paste("restriction data are missing pedon ID column: ", idn), call.=FALSE) - - # test to make sure that at least one of the IDs in candidate data are present within SPC - if(all(!unique(value[[idn]]) %in% pIDs) ) - warning('restriction data have no matching IDs in target SoilProfileCollection object!', call. = FALSE) - + if (!idn %in% nm) + stop(paste("restriction data are missing pedon ID column: ", idn), call. = FALSE) + + uidm <- unique(value[[idn]]) %in% pIDs # warn user if some of the IDs in the candidate data are missing - if(any( ! unique(value[[idn]]) %in% pIDs) ) { - warning('some records in restriction data have no matching IDs in target SoilProfileCollection object') + if (any(!uidm)) { + # test to make sure that at least one of the IDs in candidate data are present within SPC + if (all(!uidm)) { + warning('restriction data have no matching IDs in target SoilProfileCollection object!', call. = FALSE) + } else warning('some records in restriction data have no matching IDs in target SoilProfileCollection object', call. = FALSE) } # if data are already present, warn the user - if(nrow(d) > 0) - warning('overwriting existing restriction data!', call.=FALSE) + if (nrow(d) > 0) + warning('overwriting existing restriction data!', call.=FALSE) + + # convert id column to character to match @site + value[[idn]] <- as.character(value[[idn]]) + # copy data over object@restrictions <- .as.data.frame.aqp(value, metadata(object)$aqp_df_class) diff --git a/R/allocate.R b/R/allocate.R index d0b55e1c0..2a6dc9d66 100644 --- a/R/allocate.R +++ b/R/allocate.R @@ -60,10 +60,12 @@ #' #' @return A vector or \code{data.frame} object. #' +#' @author Stephen Roecker +#' #' @references -#' Abrol, I., Yadav, J. & Massoud, F. 1988. \href{https://www.fao.org/3/x5871e/x5871e00.htm}{Salt-affected soils and their management}. No. Bulletin 39. Rome, FAO Soils. +#' Abrol, I., Yadav, J. & Massoud, F. 1988. [Salt-affected soils and their management](https://www.fao.org/4/x5871e/x5871e00.htm). No. Bulletin 39. Rome, FAO Soils. #' -#' FAO. 2006. \href{https://www.fao.org/publications/card/en/c/903943c7-f56a-521a-8d32-459e7e0cdae9/}{Guidelines for soil description}. Rome, Food and Agriculture Organization of the United Nations. +#' FAO. 2006. [Guidelines for soil description](https://www.fao.org/4/a0541e/a0541e.pdf). Rome, Food and Agriculture Organization of the United Nations. #' #' FAO. 2020. DEFINITION | What is a black soil? (online). (Cited 28 December 2020). http://www.fao.org/global-soil-partnership/intergovernmental-technical-panel-soils/gsoc17-implementation/internationalnetworkblacksoils/more-on-black-soils/definition-what-is-a-black-soil/es/ #' @@ -413,7 +415,7 @@ allocate <- function(..., to = c("FAO Salt Severity", "FAO Black Soil", "ST Diag # combine results and subset to 0-25cm df_bs <- cbind(df[vars2[1:3]], BS1 = bs1, BS2 = bs2) - df_bs <- segment(df_bs, intervals = c(0, 25), hzdepcols = c("hztop", "hzbot")) + df_bs <- hz_segment(df_bs, intervals = c(0, 25), depthcols = c("hztop", "hzbot")) df_bs <- df_bs[df_bs$segment_id == "00-25", -6] # aggregate the horizons @@ -635,3 +637,266 @@ allocate <- function(..., to = c("FAO Salt Severity", "FAO Black Soil", "ST Diag return(sp) } + +#' @title Allocate Particle Size Class for the Control Section. +#' +#' @description This function aggregates information in the horizon table and allocates it to the particle size class for the control section. +#' +#' @param x a \code{data.frame} containing the original horizon table. +#' @param y a \code{data.frame} containing the particle size control section depths for each idcol. +#' @param taxpartsize \code{character} column name for taxonomic family particle size class. +#' @param clay \code{character} column name for clay percent. +# #' @param frags \code{character} column name for total rock fragments percent. +#' @param idcol character: column name of the pedon ID within the object. +#' @param depthcols a character vector of length 2 specifying the names of the horizon depths (e.g. `c("top", "bottom")`). +#' +#' +#' @details +#' This function differs from \code{\link{texture_to_taxpartsize}} in that is aggregates the results of \code{\link{texture_to_taxpartsize}}, and accounts for strongly contrasting particle size classes. +#' +#' +#' @return A \code{data.frame} object containing the original idcol, the aggregated particle size control section allocation, and an aniso column to indicate more than one contrasting class. +#' +#' @author Stephen Roecker +#' +#' @seealso [texture_to_taxpartsize()], [lookup_taxpartsize()] +#' +#' @export +#' @examples +#' +#' h <- data.frame( +#' id = 1, +#' hzname = c("A", "BA", "Bw", "BC", "C"), +#' top = c(0, 10, 45, 60, 90), +#' bottom = c(10, 45, 60, 90, 150), +#' clay = c(15, 16, 45, 20, 10), +#' sand = c(10, 35, 40, 50, 90), +#' frags = c(0, 5, 10, 38, 40) +#' ) +#' +#' h <- cbind(h, +#' texcl = ssc_to_texcl(clay = h$clay, sand = h$sand)) +#' +#' pscs <- data.frame(id = 1, +#' top = 25, +#' bottom = 100) +#' +#' h <- cbind(h, +#' taxpartsize = texture_to_taxpartsize( +#' texcl = h$texcl, +#' clay = h$clay, +#' sand = h$sand, +#' fragvoltot = h$frags +#' )) +#' +#' 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") +#' +#' hz_to_taxpartsize(horizons(h), pscs) +#' +#' +hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay", idcol = "id", depthcols = c("top", "bottom")) { + # need to incorporate fine sand for special cases of strongly contrasting classes and rock fragments (?) + # frags = "frags", + + # strongly contrasting + + x$rn <- 1:nrow(x) + # xy <- hz_intersect(x, y, idcol = idcol, depthcols = depthcols) + # x_sub <- x[x$rn %in% xy$rn, ] + + # check segment_id ---- + ## if it exists, overwrite it + x_nm <- names(x) + y_nm <- names(y) + if (any(x_nm == "segment_id") | any(y_nm == "segment_id")) { + x[x_nm == "segment_id"] <- NULL + y[y_nm == "segment_id"] <- NULL + } + + # check dissolve_id ---- + ## if it exists, overwrite it + x_nm <- names(x) + y_nm <- names(y) + if (any(x_nm == "dissolve_id") | any(y_nm == "dissolve_id")) { + x[x_nm == "dissolve_id"] <- NULL + y[y_nm == "dissolve_id"] <- NULL + } + + # standardize inputs ---- + vars <- c(idcol, depthcols, clay, taxpartsize) + x <- x[vars] + x_std <- .standardize_inputs(x, idcol = idcol, depthcols = depthcols, clay = clay, taxpartsize = taxpartsize) + x <- x_std$x; x_conv <- x_std$x_conversion + x_std <- NULL + + y <- y[c(idcol, depthcols)] + y <- .standardize_inputs(y, idcol = idcol, depthcols = depthcols)$x + + # dissolve on pscs ---- + # calculate non-trimmed horizon thickness + x_dis <- transform(hz_dissolve(x, + by = "taxpartsize", + idcol = "idcol", + depthcols = c("top", "bot")), + thk_o = bot - top) + + # trim depths ---- + # calculate trimmed horizon thickness + xy_dis <- transform(hz_intersect(x_dis, y, + idcol = "idcol", + depthcols = c("top", "bot")), + thk_t = bot - top) + + # rejoin dissolved pscs to the original horizon table ---- + xy <- suppressWarnings(hz_intersect(x, xy_dis, + idcol = "idcol", + depthcols = c("top", "bot"))) + x_dis <- NULL + xy_dis <- NULL + + # aggregate clay values within dissolved pscs ---- + top <- NULL + bot <- NULL + thk_o <- NULL + thk_t <- NULL + clay_wt <- NULL + # sandvf_wt <- NULL + + xy_agg <- data.table::as.data.table(xy)[, + list( + top = min(top, na.rm = TRUE), + bot = max(bot, na.rm = TRUE), + clay_wt = weighted.mean(clay, w = thk_t, na.rm = TRUE), + # sandvf_wt = weighted.mean(sandvf, w = thk_t, na.rm = TRUE), + # need to impute frags + # frag_wt = weighted.mean(total_frags_pct_nopf, w = thk_t), na.rm = TRUE, + thk_o = sum(thk_o, na.rm = TRUE), + thk_t = sum(thk_t, na.rm = TRUE) + ), by = c("idcol", "taxpartsize", "dissolve_id") + ] + data.table::setorder(xy_agg, idcol, top) + xy_agg <- as.data.frame(xy_agg) + + # find adjacent horizons ---- + xy_lag <- hz_lag(xy_agg, idcol = "idcol", depthcols = c("top", "bot")) + + # address special cases of strongly contrasting classes ---- + clay_wt_bot.1 <- NULL + sandvf_wt_bot.1 <- NULL + taxpartsize_bot.1 <- NULL + + # still needs special cases for very fine sand + xy_agg <- within( + cbind(xy_agg, xy_lag), + { + clay_dif = clay_wt_bot.1 - clay_wt + sc = paste0(taxpartsize, " over ", taxpartsize_bot.1) + sc = gsub(" over NA$", "", sc) + + sc = gsub("^fine over|^very-fine over", "clayey over", sc) + sc = gsub("over fine$|over very-fine$", "over clayey", sc) + sc = gsub("over fine over|over very-fine over", "over clayey over", sc) + sc = gsub("over sandy|over sandy-skeletal", "over sandy or sandy-skeletal", sc) + # clay over loamy + sc = ifelse( + abs(clay_dif) >= 25 & sc %in% c("clayey over fine-loamy", "clayey over coarse-loamy"), + gsub("clayey over fine-loamy|clayey over coarse-loamy", "clayey over loamy", sc), + sc + ) + # clay over loamy-skeletal + sc = ifelse( + sc == "clayey over loamy-skeletal" & abs(clay_dif) < 25, + taxpartsize, + sc + ) + # fine-silty over clayey + sc = ifelse( + sc == "fine-silty over clayey" & abs(clay_dif) < 25, + taxpartsize, + sc + ) + # loamy material contains less than 50 percent, by weight + # need to include a vfs percent in the function arguments, which is only present in the lab data, and otherwise you typically wouldn't assume the vfs percent is high enough to qualify for these special cases + sc = ifelse( + sc %in% c("coarse-loamy over sandy or sandy-skeletal", "loamy over sandy or sandy-skeletal", "loamy-skeletal over sandy or sandy-skeletal", "sandy over loamy", "sandy-skeletal over loamy"), + taxpartsize, + sc + ) + idx_sc = sc %in% .pscs_sc + # # sandy over loamy + # sc = ifelse( + # sc %in% c("sandy over coarse-loamy", "sandy over fine-loamy") & taxpartsize_bot.1 %in% c("coarse-loamy", "fine-loamy") & sandvf_wt_bot.1 > 50, + # "sandy over loamy", + # sc + # ) + # # sandy-skeletal over loamy + # sc = ifelse( + # sc %in% c("sandy-skeletal over coarse-loamy", "sandy over fine-loamy") & taxpartsize_bot.1 %in% c("coarse-loamy", "fine-loamy") & sandvf_wt_bot.1 > 50, + # "sandy-skeletal over loamy", + # sc + # ) + # idx_sc = grepl("over", sc) + sc = ifelse(idx_sc, sc, taxpartsize) + } + ) + xy_lag <- NULL + + # find multiple strongly contrasting ps classes within the control section + n_sc <- NULL + n_peiid <- NULL + + test <- as.data.frame(data.table::as.data.table(xy_agg)[, + list(n_sc = sum(idx_sc, na.rm = TRUE), + # sum(grepl(" over ", sc), na.rm = TRUE), + n_peiid = length(idx_sc)), + by = "idcol"]) + + # pick the sc pscs with the largest contrast or pscs with the greatest thickness + xy_res <- transform( + merge( + xy_agg, + test, + by = "idcol", + all.x = TRUE, + sort = FALSE + ), + idx_sc = sc %in% .pscs_sc, + # idx_sc = grepl(" over ", sc), + idx_c_ov_l = sc %in% c("clayey over fine-loamy") + ) + + xy_res <- within(as.data.frame( + data.table::as.data.table(xy_res)[ , + list( + pscs1 = sc[n_sc == 0 & n_peiid == 1], + pscs2 = sc[n_sc == 1 & n_peiid > 1 & idx_sc], + pscs3 = sc[which.max(thk_t[n_sc == 0 & n_peiid > 1])], + pscs4 = sc[n_sc == 1 & idx_sc], + pscs5 = sc[which.max(abs(clay_dif[n_sc > 1 & !is.na(sc)]))], + taxpartsizemod = ifelse(max(n_sc) > 1, "aniso", "not used") + ), + by = "idcol"]), + { + # need to add fix for special case of sandy over loamy which requires fine sand percent + taxpartsize = paste(pscs1, pscs3, pscs4, pscs5, sep = "") + taxpartsize = gsub("NA", "", taxpartsize) + pscs1 = NULL + pscs2 = NULL + pscs3 = NULL + pscs4 = NULL + pscs5 = NULL + }) + + # reset inputs + xy_res <- .reset_inputs(xy_res, x_conv[1]) + + return(xy_res) +} diff --git a/R/aqp-label-placement-solvers.R b/R/aqp-label-placement-solvers.R index f2806403e..9875fe35d 100644 --- a/R/aqp-label-placement-solvers.R +++ b/R/aqp-label-placement-solvers.R @@ -101,6 +101,10 @@ overlapMetrics <- function(x, thresh) { +## TODO: incorporate ideas from N-body simulation +# https://en.wikipedia.org/wiki/N-body_simulation + + #' @title Simulation of electrostatic force between two charged particles #' @description This function computes a "force" (attraction or repulsion) between two charged "particles" (usually labels or other graphical elements), using a modification of the 1D electrostatic force equation. This function is used internally for label placement in the presence of overlap, as in [fixOverlap()]. #' @@ -134,6 +138,7 @@ overlapMetrics <- function(x, thresh) { # modified version, c/o K.C. Thompson # increase const --> dampen chaotic oscillation during simulation + # "softening" in N-body simulation res <- (Qk * Q1 * Q2 ) / (d^ex + const) return(res) diff --git a/R/aqp-package.R b/R/aqp-package.R index 17ebaa818..dff4b62fb 100644 --- a/R/aqp-package.R +++ b/R/aqp-package.R @@ -20,20 +20,35 @@ #' #' #' @name aqp-package +#' #' @aliases aqp-package aqp aqp.env +#' #' @author Dylan E. Beaudette , Pierre Roudier, Andrew G. Brown +#' #' @seealso `depths<-()`, `SoilProfileCollection()`, \code{\link{sp1}}, \code{\link{sp2}}, \code{\link{sp3}}, \code{\link{sp4}}, \code{\link{sp5}}, \code{\link{sp6}} +#' #' @keywords package +#' #' @import data.table +#' #' @importFrom grDevices chull col2rgb colorRamp colorRampPalette colors convertColor grey hsv rgb rgb2hsv +#' #' @importFrom graphics abline arrows axis box grid image legend lines mtext par points polygon rect segments strheight strwidth text grconvertX +#' #' @importFrom methods setClass setOldClass representation prototype new isGeneric setGeneric setReplaceMethod setMethod .hasSlot as new slot slot<- slotNames -#' @importFrom stats TukeyHSD aggregate aov approxfun as.dist as.formula cmdscale complete.cases dist formula median model.frame na.omit na.pass quantile rnorm runif sd splinefun terms update weighted.mean +#' +#' @importFrom stats TukeyHSD aggregate aov approxfun as.dist as.formula cmdscale complete.cases dist formula median model.frame na.omit na.pass quantile rnorm runif sd splinefun terms update weighted.mean cov +#' #' @importFrom utils object.size packageVersion +#' #' @importFrom cluster pam daisy silhouette +#' #' @importFrom grid grid.text gpar unit +#' #' @importFrom graphics plot +#' #' @importFrom lattice levelplot xyplot panel.abline panel.grid panel.lines panel.points panel.polygon panel.rect panel.segments panel.text strip.custom trellis.par.get +#' "_PACKAGE" #' @export aqp.env diff --git a/R/color-palettes.R b/R/color-palettes.R new file mode 100644 index 000000000..335fc4be9 --- /dev/null +++ b/R/color-palettes.R @@ -0,0 +1,64 @@ + + +#' @title Soil Texture Color Palettes +#' +#' @description +#' Suggested color palettes for USDA soil texture classes, ranked according to average plant-available water holding capacity. The default color mapping schema is based on a palette used by SoilWeb applications. +#' +#' @param simplify logical, return the base 12 (`TRUE`) or full 21 (`FALSE`) soil texture classes +#' +#' @param schema select mapping between soil texture classes, and colors, currently limited to 'soilweb' +#' +#' @return `data.frame` from soil texture class codes and colors +#' +#' @author D.E. Beaudette, Mike Walkinshaw, A.T. O'Geen +#' +#' @export +#' +#' @rdname soilTextureColorPal +#' +#' @examples +#' +#' # base 12 soil texture classes +#' # ranked by plant available water-holding capacity +#' d <- soilTextureColorPal(simplify = TRUE) +#' soilPalette(d$color, lab = d$class, lab.cex = 1) +#' +#' # full 21 soil texture classes +#' # ranked by plant available water-holding capacity +#' d <- soilTextureColorPal(simplify = FALSE) +#' soilPalette(d$color, lab = d$class, lab.cex = 1) +#' +soilTextureColorPal <- function(simplify = FALSE, schema = 'soilweb') { + + # SoilWeb soil texture ordering, based on ranking of PAWS of + .l <- c("s", "ls", "sl", "scl", "l", "sc", "c", "sic", "cl", "sil", "sicl", "si") + + .cols <- c( + "#BEBEBE", "#FDFD9E", "#ebd834", "#92C158", "#307431", "#4C5323", + "#AF4732", "#E93F4A", "#EA6996", "#CD94EA", "#6D94E5", "#546BC3" + ) + + # expanded soil texture ordering to include all 21 classes, + # from SoilWeb color palette of 12 base classes + .le <- c("cos", "s", "fs", "vfs", "lcos", "ls", "lfs", "lvfs", "cosl", "sl", "fsl", "vfsl", "scl", "l", "sc", "c", "sic", "cl", "sil", "sicl", "si") + + # linear interpolation required to prevent wild "blue" colors on the sandy side + # bias required as we are increasing the resolution on the coarse side of the scalee + .cols_e <- colorRampPalette( + colors = .cols, + space = 'Lab', + interpolate = 'linear', + bias = 0.45 + )(21) + + if(simplify) { + res <- data.frame(class = .l, color = .cols) + } else { + res <- data.frame(class = .le, color = .cols_e) + } + + return(res) + +} + diff --git a/R/data-documentation.R b/R/data-documentation.R index 13e7ae98a..baa09d78e 100644 --- a/R/data-documentation.R +++ b/R/data-documentation.R @@ -129,7 +129,7 @@ #' character vector} \item{field_ph}{a numeric vector} #' \item{hue}{a character vector} \item{value}{a numeric #' vector} \item{chroma}{a numeric vector} } -#' @references \url{http://casoilresource.lawr.ucdavis.edu/} +#' @references \url{https://casoilresource.lawr.ucdavis.edu/} #' @keywords datasets #' @examples #' @@ -190,7 +190,7 @@ NULL #' \item{b}{RGB blue component} \item{soil_color}{R-friendly #' encoding of soil color} } #' @author Dylan E. Beaudette -#' @references \url{http://casoilresource.lawr.ucdavis.edu/} +#' @references \url{https://casoilresource.lawr.ucdavis.edu/} #' @source Busacca, Alan J.; Singer, Michael J.; Verosub, Kenneth L. 1989. Late #' Cenozoic stratigraphy of the Feather and Yuba rivers area, California, with #' a section on soil development in mixed alluvium at Honcut Creek. USGS @@ -267,7 +267,7 @@ NULL #' \item{B}{color: b-coordinate, CIE-LAB colorspace (dry)} #' \item{name}{horizon name} \item{soil_color}{horizon color} } #' @keywords datasets -#' @references \url{http://casoilresource.lawr.ucdavis.edu/} +#' @references \url{https://casoilresource.lawr.ucdavis.edu/} #' @examples #' #' ## this example investigates the concept of a "median profile" diff --git a/R/depthOf.R b/R/depthOf.R index 74b689d5a..76a6f6e96 100644 --- 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/similarMunsellChips.R b/R/equivalentMunsellChips.R similarity index 94% rename from R/similarMunsellChips.R rename to R/equivalentMunsellChips.R index 06bc2b0f4..baa90f78f 100644 --- a/R/similarMunsellChips.R +++ b/R/equivalentMunsellChips.R @@ -9,7 +9,7 @@ #' @references #' Gaurav Sharma, Wencheng Wu, Edul N. Dalal. (2005). The CIEDE2000 Color-Difference Formula: Implementation Notes, Supplementary Test Data, and Mathematical Observations. COLOR research and application. 30(1):21-30. http://www2.ece.rochester.edu/~gsharma/ciede2000/ciede2000noteCRNA.pdf #' -#' Thomas Lin Pedersen, Berendea Nicolae and Romain François (2020). farver: High Performance Colour Space Manipulation. R package version 2.0.3. https://CRAN.R-project.org/package=farver +#' Thomas Lin Pedersen, Berendea Nicolae and Romain François (2020). farver: High Performance Colour Space Manipulation. R package version 2.0.3. https://CRAN.R-project.org/package=farver #' #' Dong, C.E., Webb, J.B., Bottrell, M.C., Saginor, I., Lee, B.D. and Stern, L.A. (2020). Strengths, Limitations, and Recommendations for Instrumental Color Measurement in Forensic Soil Characterization. J Forensic Sci, 65: 438-449. https://doi.org/10.1111/1556-4029.14193 #' @@ -50,7 +50,8 @@ .makeEquivalentMunsellLUT <- function(threshold = 0.001) { munsell <- NULL load(system.file("data/munsell.rda", package = "aqp")[1]) - + + # 2024-10-04: added 8.5 and 9.5 value chips # 2022-03-31: updated neutral chips and 2.5 value chips now included @@ -72,16 +73,22 @@ # user system elapsed # 190.73 0.73 194.42 system.time( - x <- farver::compare_colour(from = munsell[,c('L','A','B')], from_space = 'lab', - to = munsell[,c('L','A','B')], to_space = 'lab', - method = 'cie2000', white_from = 'D65', white_to = 'D65') + x <- farver::compare_colour( + from = munsell[, c('L', 'A', 'B')], + from_space = 'lab', + to = munsell[, c('L', 'A', 'B')], + to_space = 'lab', + method = 'cie2000', + white_from = 'D65', + white_to = 'D65' + ) ) xdat <- x x[lower.tri(x, diag = TRUE)] <- NA # remove lower triangle for statistics (only count each pair distance 1x) - # roughly dE00 ~ 2.24 -- this is close to the perceptible limit of average human color vision with "good" lighting + # dE00 ~2.158 -- this is close to the perceptible limit of average human color vision with "good" lighting # calculate quantiles xqtl <- quantile(x, p = threshold, na.rm = TRUE)[1] @@ -134,7 +141,7 @@ names(equivalent_munsell) <- sprintf("%s %s/%s", munsell$hue, munsell$value, munsell$chroma) # this is only 107kB written to Rda - # save(equivalent_munsell, file="data/equivalent_munsell.rda") + save(equivalent_munsell, file="data/equivalent_munsell.rda") return(equivalent_munsell) } @@ -147,7 +154,7 @@ #' #' The intention is to identify Munsell chips that may be "functionally equivalent" to some other given whole value/chroma chip elsewhere in the Munsell color space -- as discretized in the \code{aqp::munsell} data table. This basic assumption needs to be validated against your end goal: probably by visual inspection of some or all of the resulting sets. See \code{\link{colorContrast}} and \code{\link{colorContrastPlot}}. #' -#' "Equivalent" chips table are based (fairly arbitrarily) on the 0.001 probability level of dE00 (default Type 7 \code{quantile}) within the upper triangle of the 8467x8467 contrast matrix. This corresponds to a \code{dE00} contrast threshold of approximately 2.15. +#' "Equivalent" chips table are based (fairly arbitrarily) on the 0.001 probability level of dE00 (default Type 7 \code{quantile}) within the upper triangle of the 8467x8467 contrast matrix. This corresponds to a \code{dE00} contrast threshold of approximately 2.16. #' @param hue A character vector containing Munsell hues #' @param value A numeric vector containing Munsell values (integer only) diff --git a/R/estimatePSCS.R b/R/estimatePSCS.R index 87b92bbd0..2ebb3e92f 100644 --- a/R/estimatePSCS.R +++ b/R/estimatePSCS.R @@ -51,15 +51,23 @@ #' 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", lieutex = "lieutex", - bottom.pattern='Cr|R|Cd|m', 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|m', + simplify = TRUE, + ... +) { .LAST <- NULL hz.depths <- horizonDepths(p) @@ -67,23 +75,17 @@ estimatePSCS = function(p, hzdesgn = "hzname", clay.attr = "clay", 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/evalGenHz.R b/R/evalGenHz.R index 7c40c0eae..0b94015ea 100644 --- a/R/evalGenHz.R +++ b/R/evalGenHz.R @@ -4,36 +4,42 @@ #' Data-driven evaluation of generalized horizon labels using nMDS and #' silhouette width. #' -#' Non-metric multidimensional scaling is performed via \code{\link{isoMDS}}. -#' The input distance matrix is generated by \code{\link{daisy}} using -#' (complete cases of) horizon-level attributes from \code{obj} as named in -#' \code{vars}. +#' Non-metric multidimensional scaling is performed via [MASS::isoMDS()]. +#' The input distance matrix is generated by [cluster::daisy()] using +#' (complete cases of) horizon-level attributes from `obj` as named in +#' `vars`. #' -#' Silhouette widths are computed via \code{\link{silhouette}}. The input -#' distance matrix is generated by \code{\link{daisy}} using (complete cases -#' of) horizon-level attributes from \code{obj} as named in \code{vars}. Note -#' that observations with genhz labels specified in \code{non.matching.code} +#' Silhouette widths are computed via [cluster::silhouette()]. The input +#' distance matrix is generated by [cluster::daisy()] using (complete cases +#' of) horizon-level attributes from `obj` as named in `vars`. Note +#' that observations with genhz labels specified in `non.matching.code` #' are removed filtered before calculation of the distance matrix. #' -#' @param obj a \code{SoilProfileCollection} object -#' @param genhz name of horizon-level attribute containing generalized horizon -#' labels -#' @param vars character vector of horizon-level attributes to include in the -#' evaluation -#' @param non.matching.code code used to represent horizons not assigned a -#' generalized horizon label -#' @param stand standardize variables before computing distance matrix (default -#' = TRUE), passed to \code{\link{daisy}} -#' @param trace verbose output from passed to \code{\link{isoMDS}}, (default = -#' FALSE) -#' @param metric distance metric, passed to \code{\link{daisy}} -#' @return a list is returned containing: \describe{ \item{horizons}{c('mds.1', -#' 'mds.2', 'sil.width', 'neighbor')} \item{stats}{mean and standard deviation -#' of \code{vars}, computed by generalized horizon label} \item{dist}{the -#' distance matrix as passed to \code{\link{isoMDS}}} } +#' @param obj a `SoilProfileCollection` object +#' +#' @param genhz name of horizon-level attribute containing generalized horizon labels +#' +#' @param vars character vector of horizon-level attributes to include in the evaluation +#' +#' @param non.matching.code code used to represent horizons not assigned a generalized horizon label +#' +#' @param stand standardize variables before computing distance matrix, passed to [cluster::daisy()] +#' +#' @param trace verbose output from passed to [MASS::isoMDS()] +#' +#' @param metric distance metric, passed to [cluster::daisy()] +#' +#' @return a list is returned containing: +#' * horizons: `c('mds.1', mds.2', 'sil.width', 'neighbor')` +#' * stats: mean and standard deviation `vars`, computed by generalized horizon label +#' * dist: the distance matrix as passed to [MASS::isoMDS()] +#' #' @author D.E. Beaudette -#' @seealso \code{\link{get.ml.hz}} +#' +#' @seealso [get.ml.hz()] +#' #' @keywords manip +#' #' @export evalGenHZ <- function(obj, genhz = GHL(obj, required = TRUE), vars, non.matching.code='not-used', stand=TRUE, trace=FALSE, metric='euclidean') { if(!requireNamespace("MASS", quietly = TRUE)) diff --git a/R/factor-level-setters.R b/R/factor-level-setters.R index aeb0871e5..102f2cd25 100644 --- a/R/factor-level-setters.R +++ b/R/factor-level-setters.R @@ -1,5 +1,3 @@ -## -## ## TODO: consider various sorting strategies: WMPD, AWC, {PWP,FC,SAT} ## http://ncss-tech.github.io/AQP/aqp/water-retention-curves.html @@ -25,8 +23,11 @@ #' @references \href{https://nrcspad.sc.egov.usda.gov/DistributionCenter/product.aspx?ProductID=991}{Field Book for Describing and Sampling Soils, version 3.0} #' #' @param which 'codes' (texture codes) or 'names' (texture class names) +#' #' @param simplify Return 12-class factor levels (`TRUE`) or 21-class factor levels (default: `FALSE`)? The 12-class system does not separate sands, loamy sands and sandy loams into sand fraction variants (e.g. "very fine sandy loam" in the 21-class system is "sandy loam" in 12-class system) +#' #' @return an ordered factor +#' #' @export #' @examples #' @@ -48,21 +49,25 @@ SoilTextureLevels <- function(which = 'codes', simplify = FALSE) { # sorted by approximate particle size if (!simplify) { # from the Field Book version 3.0 - tx <- data.frame(texture = c("coarse sand", "sand", "fine sand", - "very fine sand", "loamy coarse sand", "loamy sand", "loamy fine sandy", - "loamy very fine sand", "coarse sandy loam", "sandy loam", "fine sandy loam", - "very fine sandy loam", "loam", "silt loam", "silt", "sandy clay loam", - "clay loam", "silty clay loam", "sandy clay", "silty clay", "clay"), - texcl = c("cos", "s", "fs", "vfs", "lcos", "ls", "lfs", "lvfs", - "cosl", "sl", "fsl", "vfsl", "l", "sil", "si", "scl", "cl", "sicl", - "sc", "sic", "c")) + tx <- data.frame( + texture = c("coarse sand", "sand", "fine sand", + "very fine sand", "loamy coarse sand", "loamy sand", "loamy fine sandy", + "loamy very fine sand", "coarse sandy loam", "sandy loam", "fine sandy loam", + "very fine sandy loam", "loam", "silt loam", "silt", "sandy clay loam", + "clay loam", "silty clay loam", "sandy clay", "silty clay", "clay"), + texcl = c("cos", "s", "fs", "vfs", "lcos", "ls", "lfs", "lvfs", + "cosl", "sl", "fsl", "vfsl", "l", "sil", "si", "scl", "cl", "sicl", + "sc", "sic", "c") + ) } else { # From Soil Survey Manual (1951) p. 210 - tx <- data.frame(texture = c("sand", "loamy sand", "sandy loam", - "loam", "silt loam", "silt", "sandy clay loam", - "clay loam", "silty clay loam", - "sandy clay", "silty clay", "clay"), - texcl = c("s", "ls", "sl", "l", "sil", "si", - "scl", "cl", "sicl", "sc", "sic", "c")) + tx <- data.frame( + texture = c("sand", "loamy sand", "sandy loam", + "loam", "silt loam", "silt", "sandy clay loam", + "clay loam", "silty clay loam", + "sandy clay", "silty clay", "clay"), + texcl = c("s", "ls", "sl", "l", "sil", "si", + "scl", "cl", "sicl", "sc", "sic", "c") + ) } # set levels diff --git a/R/flagOverlappingHz.R b/R/flagOverlappingHz.R index a7808884a..4dfd973b7 100644 --- a/R/flagOverlappingHz.R +++ b/R/flagOverlappingHz.R @@ -5,9 +5,13 @@ #' #' @return logical vector with length (and order) matching the horizons of `x` #' -#' @author D.E. Beaudette +#' @author D.E. Beaudette, A.G. Brown #' #' @export +#' @details +#' Horizons with `NA` depths can be flagged as overlapping. Consider finding these horizons with `checkHzDepthLogic(byhz=TRUE)` and removing or fixing them. +#' +#' @seealso [checkHzDepthLogic()] [fillHzGaps()] #' #' @examples #' @@ -29,43 +33,33 @@ #' depth.axis = FALSE, cex.names = 0.85) #' flagOverlappingHz <- function(x) { + h <- horizons(x) + idn <- idname(x) + hzd <- horizonDepths(x) + + # extract horizon depths and profile ID + .id <- h[[idn]] + .fid <- as.numeric(factor(.id)) + .tops <- paste0(.fid, ":", h[[hzd[1]]]) + .bottoms <- paste0(.fid, ":", h[[hzd[2]]]) + + # missing depths are recoded so they will be recognized as runs with length >1 + + .rt <- rle(.tops) + .rb <- rle(.bottoms) + .ot <- .rt$values[which(.rt$lengths > 1)] + .ob <- .rb$values[which(.rb$lengths > 1)] + + # index affected horizons + .m1 <- outer(.ot, .tops, '==') + .m2 <- outer(.ob, .bottoms, '==') - # crude prototype, single profile at a time - .fo <- function(i) { - - # for R CMD check - .TOP <- NULL - .BOTTOM <- NULL - - # tops / bottoms - # NA not currently handled - .tops <- i[, , .TOP] - .bottoms <- i[, , .BOTTOM] - - # find perfect overlap - .rt <- rle(.tops) - .rb <- rle(.bottoms) - - # id affected horizons - .ot <- .rt$values[which(.rt$lengths > 1)] - .ob <- .rb$values[which(.rb$lengths > 1)] - - ## TODO: tests required - # index affected horizons - .m <- outer(.ot, .tops, '==') - idx <- unlist(as.vector(apply(.m, 1, which))) - - # generate flag vector along sequence of horizons - .res <- rep(FALSE, times = length(.tops)) - .res[idx] <- TRUE - - return(.res) - } + idx1 <- unlist(as.vector(apply(.m1, 1, which))) + idx2 <- unlist(as.vector(apply(.m2, 1, which))) - # TODO: can probably be made faster - # * only hz data required - # * split (profile ID) / apply (.fo()) / combine via DT (returns vector) - res <- profileApply(x, .fo, simplify = TRUE) - return(res) + # generate flag vector along sequence of horizons + .res <- rep(FALSE, times = length(.tops)) + .res[intersect(idx1, idx2)] <- TRUE + .res } diff --git a/R/getArgillicBounds.R b/R/getArgillicBounds.R index f7e88384b..51baf8951 100644 --- 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 index 9dbe6aedf..58702caf7 100644 --- a/R/getCambicBounds.R +++ b/R/getCambicBounds.R @@ -38,16 +38,19 @@ #' #' # 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", @@ -55,9 +58,13 @@ getCambicBounds <- function(p, 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/getClosestMunsellChip.R b/R/getClosestMunsellChip.R index 4c32de97b..81bed1fdd 100644 --- a/R/getClosestMunsellChip.R +++ b/R/getClosestMunsellChip.R @@ -3,7 +3,7 @@ #' #' @description Non-standard Munsell notation ('7.9YR 2.7/2.0') can be matched (nearest-neighbor, no interpolation) to the closest color within the `munsell` sRGB/CIELAB look-up table via `getClosestMunsellChip()`. A more accurate estimate of sRGB values from non-standard notation can be achieved with the \href{https://CRAN.R-project.org/package=munsellinterpol}{munsellinterpol} package. For example, conversion from Munsell to CIELAB, assuming a D65 illuminant via: `MunsellToLab('0.1Y 3.3/4.4', white='D65', adapt='Bradford')`. #' -#' @param munsellColor character vector of strings containing Munsell notation of color, e.g. '10YR 4/3' +#' @param munsellColor character vector of strings containing Munsell notation of color, e.g. '10YR 4/3', not NA-safe #' @param convertColors logical, should parsed Munsell colors be converted into sRGB values #' @param ... further arguments to \code{munsell2rgb} #' @@ -30,6 +30,20 @@ getClosestMunsellChip <- function(munsellColor, convertColors = TRUE, ...) { # This is a hack to avoid munsell2rgb: "no visible binding for global variable munsell" at package R CMD check munsell <- NULL + # # init working vectors + # # for NA propagation + # n <- length(munsellColor) + # closest.hue <- vector(mode = 'character', length = n) + # closest.value <- vector(mode = 'numeric', length = n) + # closest.chroma <- vector(mode = 'numeric', length = n) + # + # # remove NA for now + # na.idx <- which(is.na(munsellColor)) + # if(length(na.idx) > 0) { + # x.na <- x[na.idx] + # x <- x[-na.idx] + # } + # extract hue, value, chroma from single string cd <- parseMunsell(munsellColor, convertColors = FALSE) @@ -41,21 +55,27 @@ getClosestMunsellChip <- function(munsellColor, convertColors = TRUE, ...) { ## -> interpreting 10YR as the same as 0Y + ## TODO: make NA-safe + + # note: this is incompatible with LazyData: true # extract pieces from unique Munsell hues - load(system.file("data/munsell.rda", package="aqp")[1]) + load(system.file("data/munsell.rda", package = "aqp")[1]) all.hue.data <- na.omit(.parseMunsellHue(unique(munsell$hue))) # locate closest chip in `munsell` set of hues - closest.hue <- vector(mode = 'character', length=nrow(hue.data)) + closest.hue <- vector(mode = 'character', length = nrow(hue.data)) for(i in 1:nrow(hue.data)) { # index possible rows based on character part of hue idx <- which(all.hue.data$hue.character == hue.data[i, ]$hue.character) + # compute Euclidean distance to all possible numeric parts of hue distances <- abs(hue.data$hue.numeric[i] - all.hue.data$hue.numeric[idx]) closest.idx <- which.min(distances) + # compile closest hue closest.hue[i] <- paste0(all.hue.data[idx, ][closest.idx, ], collapse = '') + } # valid value / chroma in our LUT diff --git a/R/getSurfaceHorizonDepth.R b/R/getSurfaceHorizonDepth.R index 94ac82960..8768f5e19 100644 --- 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)) } diff --git a/R/glom.R b/R/glom.R index 8bc7f450d..2f517edbb 100644 --- a/R/glom.R +++ b/R/glom.R @@ -259,20 +259,20 @@ setMethod("glom", signature(p = "SoilProfileCollection"), p <- .updateSite(p, h) } - if (nrow(h) > 0) { - if (!fill) { + if (fill) { + p <- .insert_dropped_horizons(p, horizons = h) + } else { + if (nrow(h) > 0) { # replace @horizons with h replaceHorizons(p) <- h # if pre-existing "filled" horizons are present, drop them p <- p[!isEmpty(p),] } else { - p <- .insert_dropped_horizons(p, horizons = h) + p <- p[0, ] } - } else { - p <- p[0,] } - + # short circuit to get hzIDs of result if (ids) { if (invert) diff --git a/R/guessColumnNames.R b/R/guessColumnNames.R index af635c9cf..1c2f294e2 100644 --- a/R/guessColumnNames.R +++ b/R/guessColumnNames.R @@ -6,10 +6,10 @@ #' #' e.g. \code{guessHzAttrName(x, attr="clay", optional=c("total", "_r"))} matches (\code{claytotal_r == totalclay_r}) over (\code{clay_r == claytotal == totalclay}) over \code{clay}. #' -#' @param x A SoilProfileCollection -#' @param attr A regular expression containing required formative element of attribute name. -#' @param optional A character vector of regular expression(s) containing optional formative elements of attribute name. -#' @param verbose A boolean value for whether to produce message output about guesses. +#' @param x A _SoilProfileCollection_ +#' @param attr _character_. A regular expression containing required formative element of attribute name. +#' @param optional _character_. Vector of regular expression(s) containing optional formative elements of attribute name. +#' @param verbose _logical_. Produce message output about guesses? Default: `TRUE` #' #' @return Character containing horizon attribute column name. Result is the first match in \code{horizonNames(x)} with the most required plus optional patterns matched. #' @@ -46,15 +46,15 @@ guessHzAttrName <- function(x, attr, optional = NULL, verbose = TRUE, required = FALSE) { nm <- horizonNames(x) - if(!inherits(x, 'SoilProfileCollection')) { + if (!inherits(x, 'SoilProfileCollection')) { stop("x must be a SoilProfileCollection") } # possible names include column names with name in the name - req <- grepl(attr, nm, ignore.case=TRUE) + req <- grepl(attr, nm, ignore.case = TRUE) - opt <- lapply(as.list(optional), function(i) grepl(i, nm, ignore.case=TRUE)) - if(is.null(optional) | length(optional) == 0) + opt <- lapply(as.list(optional), function(i) grepl(i, nm, ignore.case = TRUE)) + if (is.null(optional) | length(optional) == 0) opt <- as.list(req) opt <- rowSums(do.call('cbind', opt)) @@ -70,15 +70,15 @@ guessHzAttrName <- function(x, attr, optional = NULL, verbose = TRUE, required = # return first index matching in decreasing precedence # all optional met, some optional met, basic requirement met, no requirement met res <- NA - if(length(idx1)) { + if (length(idx1)) { res <- nm[idx1[1]] - } else if(length(idx2)) { + } else if (length(idx2)) { res <- nm[idx2[1]] - } else if(length(idx3)) { + } else if (length(idx3)) { res <- nm[idx3[1]] } - if(!is.na(res)) { - if(verbose) + if (!is.na(res)) { + if (verbose) message(sprintf('guessing horizon attribute \'%s\' is stored in `%s`', attr, res)) } else { msg <- sprintf('unable to guess column containing horizon attribute \'%s\'', attr) @@ -90,7 +90,7 @@ guessHzAttrName <- function(x, attr, optional = NULL, verbose = TRUE, required = return(res) } -#' @description `guessHzDesgnName()`: This follows the historic convention used by \code{aqp::plotSPC()} looking for "hzname" or other column names containing the regular expression "name". If the pattern "name" is not found, the pattern "desgn" is searched as a fallback, as "hzdesgn" or "hz_desgn" are other common column naming schemes for horizon designation name. +#' @description `guessHzDesgnName()`: **DEPRECATED** This follows the historic convention used by \code{aqp::plotSPC()} looking for "hzname" or other column names containing the regular expression "name". If the pattern "name" is not found, the pattern "desgn" is searched as a fallback, as "hzdesgn" or "hz_desgn" are other common column naming schemes for horizon designation name. #' #' @param x A SoilProfileCollection #' @param required logical Default: `FALSE`. Is this attribute required? If it is, set to `TRUE` to trigger error on invalid value. @@ -98,23 +98,14 @@ guessHzAttrName <- function(x, attr, optional = NULL, verbose = TRUE, required = #' @rdname guessHzAttrName #' #' @export -#' -#' @examples -#' -#' a <- data.frame(id = 1, top = c(0,10), bottom=c(10,40), horizonname=c("A","Bw")) -#' depths(a) <- id ~ top + bottom -#' -#' # store guess in metadata -#' hzdesgnname(a) <- guessHzDesgnName(a) -#' -#' # inspect result -#' hzdesgnname(a) -#' guessHzDesgnName <- function(x, required = FALSE) { + + .Deprecated(msg = "`guessHzDesgnName()` is deprecated. Use `hzdesgnname()` (with `required=TRUE` argument if needed), or use `guessHzAttrName()` with appropriate values for your use case") + nm <- horizonNames(x) name <- NA - if(!inherits(x, 'SoilProfileCollection')) { + if (!inherits(x, 'SoilProfileCollection')) { stop("x must be a SoilProfileCollection") } @@ -125,10 +116,10 @@ guessHzDesgnName <- function(x, required = FALSE) { } # possible names include column names with name in the name - possible.name <- nm[grep('name', nm, ignore.case=TRUE)] + possible.name <- nm[grep('name', nm, ignore.case = TRUE)] # use the first valid guess - if(length(possible.name) > 0) { + if (length(possible.name) > 0) { possible.name <- possible.name[1] name <- possible.name } else { @@ -148,24 +139,15 @@ guessHzDesgnName <- function(x, required = FALSE) { return(name) } -#' @description `guessHzTexClName()`: This function is used to provide a texture class attribute column name to functions. It will use regular expressions to match "texcl" which is typically the texture of the fine earth fraction, without modifiers or in-lieu textures. Alternately, it will match "texture" for cases where "texcl" is absent (e.g. in NASIS Component Horizon). +#' @description `guessHzTexClName()`: **DEPRECATED** This function is used to provide a texture class attribute column name to functions. It will use regular expressions to match "texcl" which is typically the texture of the fine earth fraction, without modifiers or in-lieu textures. Alternately, it will match "texture" for cases where "texcl" is absent (e.g. in NASIS Component Horizon). #' #' @rdname guessHzAttrName #' #' @export guessHzTexClName -#' -#' @examples -#' -#' a <- data.frame(id = 1, top = c(0,10), bottom=c(10,40), texture=c("A","Bw")) -#' depths(a) <- id ~ top + bottom -#' -#' # store guess in metadata -#' hztexclname(a) <- guessHzTexClName(a) -#' -#' # inspect result -#' hztexclname(a) -#' guessHzTexClName <- function(x, required = FALSE) { + + .Deprecated(msg = "`guessHzTexClName()` is deprecated. Use `hztexclname()` (with `required=TRUE` argument if needed), or use `guessHzAttrName()` with appropriate values for your use case") + nm <- horizonNames(x) if (!inherits(x, 'SoilProfileCollection')) { diff --git a/R/huePosition.R b/R/huePosition.R index 2888e982d..153c45e44 100644 --- a/R/huePosition.R +++ b/R/huePosition.R @@ -1,4 +1,7 @@ +## TODO: consider hue-based, angular distance between 2 hues + + #' @title Munsell Hue Reference and Position Searching #' #' @description The 40 Munsell hues are typically arranged from 5R to 2.5R moving clock wise on the unit circle. This function matches a vector of hues to positions on that circle, with options for setting a custom origin or search direction. @@ -54,6 +57,7 @@ #' par(op) #' huePosition <- function(x, returnHues = FALSE, includeNeutral = FALSE, origin = '5R', direction = c('cw', 'ccw')) { + # ordering via Tech Note #2 # Soil Survey Technical Note 2 [wayback machine URL](https://web.archive.org/web/20220704214918/https://www.nrcs.usda.gov/wps/portal/nrcs/detail/soils/ref/?cid=nrcs142p2_053569) @@ -62,7 +66,7 @@ huePosition <- function(x, returnHues = FALSE, includeNeutral = FALSE, origin = # note: this is incompatible with LazyData: true # load look-up table from our package - load(system.file("data/munsellHuePosition.rda", package="aqp")[1]) + load(system.file("data/munsellHuePosition.rda", package = "aqp")[1]) ## basic error checking / argument processing diff --git a/R/mollicEpipedon.R b/R/mollicEpipedon.R index fb67817f2..11c21be85 100644 --- a/R/mollicEpipedon.R +++ b/R/mollicEpipedon.R @@ -37,9 +37,9 @@ #' clay.attr='prop', truncate=FALSE)) #' mollic.thickness.requirement <- function(p, - hzdesgn = guessHzDesgnName(p), - texcl.attr = guessHzTexClName(p), - clay.attr = guessHzAttrName(p, 'clay', c('total','_r')), + hzdesgn = hzdesgnname(p, required = TRUE), + texcl.attr = hztexclname(p, required = TRUE), + clay.attr = hzmetaname(p, "clay", required = TRUE), truncate = TRUE) { hzd <- horizonDepths(p) diff --git a/R/munsell2rgb.R b/R/munsell2rgb.R index 658d91fb3..71506fede 100644 --- a/R/munsell2rgb.R +++ b/R/munsell2rgb.R @@ -181,8 +181,25 @@ rgb2munsell <- function(color, colorSpace = c('CIE2000', 'LAB', 'sRGB'), nCloses - - +# internally used function for snapping a vector of user-supplied values +# to a known subset via absolute distance +# NA safely propagated +.snapValid <- function(s, v) { + # rows are distances by the_value + .dist <- outer(s, v, function(i, j) {abs(i - j)}) + + # index to snapped values, safely handle NA + idx <- apply(.dist, 1, function(i) { + if(all(is.na(i))) { + return(NA) + } else { + return(which.min(i)) + } + }) + + # replace with snapped + NA + return(v[idx]) +} @@ -232,69 +249,56 @@ rgb2munsell <- function(color, colorSpace = c('CIE2000', 'LAB', 'sRGB'), nCloses #' @examples #' #' # neutral hues (N) can be defined with chroma of 0 or NA -#' g <- expand.grid(hue='N', value=2:8, chroma=0, stringsAsFactors=FALSE) +#' g <- expand.grid(hue='N', value = 2:8, chroma = 0, stringsAsFactors = FALSE) #' (m <- munsell2rgb(g$hue, g$value, g$chroma)) #' soilPalette(m) #' -#' # back-transform -#' rgb2munsell(t(col2rgb(m)) / 255) +#' # back-transform to Munsell notation +#' col2Munsell(t(col2rgb(m)) / 255) #' #' #' # basic example -#' d <- expand.grid(hue='10YR', value=2:8, chroma=1:8, stringsAsFactors=FALSE) +#' d <- expand.grid(hue = '10YR', value = 2:8, chroma = 1:8, stringsAsFactors = FALSE) #' d$color <- with(d, munsell2rgb(hue, value, chroma)) #' #' # similar to the 10YR color book page -#' plot(value ~ chroma, data=d, col=d$color, pch=15, cex=3) +#' plot(value ~ chroma, data = d, col = d$color, pch = 15, cex = 3, las = 1) #' #' # multiple pages of hue: -#' hues <- c('2.5YR','5YR','7.5YR','10YR') -#' d <- expand.grid(hue=hues, value=c(2, 2.5, 3:8), chroma=seq(2,8,by=2), stringsAsFactors=FALSE) +#' hues <- c('2.5YR', '5YR', '7.5YR', '10YR') +#' d <- expand.grid( +#' hue = hues, +#' value = c(2, 2.5, 3:8), +#' chroma = seq(2, 8, by = 2), +#' stringsAsFactors = FALSE +#' ) #' # convert Munsell -> sRGB #' d$color <- with(d, munsell2rgb(hue, value, chroma)) #' #' # extract CIELAB coordinates -#' with(d, munsell2rgb(hue, value, chroma, returnLAB=TRUE)) +#' with(d, munsell2rgb(hue, value, chroma, returnLAB = TRUE)) #' #' # plot: note that we are setting panel order from red --> yellow #' library(lattice) -#' xyplot(value ~ factor(chroma) | factor(hue, levels=hues), -#' main="Common Soil Colors", layout=c(4,1), scales=list(alternating=1), -#' strip=strip.custom(bg=grey(0.85)), -#' data=d, as.table=TRUE, subscripts=TRUE, xlab='Chroma', ylab='Value', -#' panel=function(x, y, subscripts, ...) -#' { -#' panel.xyplot(x, y, pch=15, cex=4, col=d$color[subscripts]) -#' } +#' xyplot( +#' value ~ factor(chroma) | factor(hue, levels = hues), +#' main = "Common Soil Colors", layout = c(4, 1), scales = list(alternating = 1), +#' strip = strip.custom(bg = grey(0.85)), +#' data = d, as.table = TRUE, subscripts = TRUE, +#' xlab = 'Chroma', ylab = 'Value', +#' panel = function(x, y, subscripts, ...) { +#' panel.xyplot(x, y, pch = 15, cex = 4, col = d$color[subscripts]) +#' } #' ) +#' #' #' -#' # soils example -#' data(sp1) -#' -#' # convert colors -#' sp1$soil_color <- with(sp1, munsell2rgb(hue, value, chroma)) -#' -#' # simple plot, may need to tweak gamma-correction... -#' image(matrix(1:nrow(sp1)), axes=FALSE, col=sp1$soil_color, main='Soil Colors') -#' -#' # convert into a more useful color space -#' # you will need the colorspace package for this to work -#' if(require(colorspace)) { -#' # keep RGB triplets from conversion -#' sp1.rgb <- with(sp1, munsell2rgb(hue, value, chroma, return_triplets=TRUE)) -#' -#' # convert into LAB color space -#' sp1.lab <- as(with(sp1.rgb, sRGB(r,g,b)), 'LAB') -#' plot(sp1.lab) -#' } -#' #' # convert a non-standard color to closest "chip" in `munsell` look-up table #' getClosestMunsellChip('7.9YR 2.7/2.0', convertColors = FALSE) -#' # convert directly to R color +#' +#' # convert directly to hex notation of sRGB #' getClosestMunsellChip('7.9YR 2.7/2.0') - - +#' munsell2rgb <- function(the_hue, the_value, the_chroma, alpha = 1, maxColorValue = 1, return_triplets = FALSE, returnLAB = FALSE) { ## important: change the default behavior of data.frame and melt opt.original <- options(stringsAsFactors = FALSE) @@ -336,31 +340,50 @@ munsell2rgb <- function(the_hue, the_value, the_chroma, alpha = 1, maxColorValue ## they will typically be missing chroma or have some arbitrary number ## set it to 0 for correct matching N.idx <- which(the_hue == 'N') - if(length(N.idx) > 0) + if(length(N.idx) > 0) { the_chroma[N.idx] <- 0 + } + + + ## any other hue with 0 chroma should be interpreted as N + idx <- which(the_hue != 'N' & the_chroma == 0) + if(length(idx > 0)) { + the_hue[idx] <- 'N' + } + - # value / chroma should be within unique set of allowed chips - valid.value <- unique(as.character(munsell$value)) - valid.chroma <- unique(as.character(munsell$chroma)) + ## value / chroma should be within unique set of allowed chips - ## warn if non-standard notation + # the valid range depends on the latest version of the munsell LUT + # https://github.com/ncss-tech/aqp/issues/318 + valid.value <- unique(munsell$value) + valid.chroma <- unique(munsell$chroma) - ## TODO: should rounding be enabled by default for backwards compatibility? - ## TODO: rounding is wrong with e.g. 10YR 2.6 / 3 --> closest value is 2.5 - # value - if(any(! as.character(na.omit(the_value)) %in% valid.value)) { - warning("non-standard notation in Munsell value, use getClosestMunsellChip()", call. = FALSE) - the_value <- ifelse(as.character(the_value) %in% valid.value, the_value, round(the_value)) + # test Munsell values + if(any(! na.omit(the_value) %in% valid.value)) { + warning("non-standard notation in Munsell value, snapping to the nearest available value\n consider using getClosestMunsellChip()", call. = FALSE) + + ## TODO: optimize by only computing distances for non-standard Munsell value + + # snap supplied Munsell value to valid value via absolute distance + # NA are safely propagated + the_value <- .snapValid(the_value, valid.value) } - # chroma - if(any(! as.character(na.omit(the_chroma)) %in% valid.chroma)) { - warning("non-standard notation in Munsell chroma, use getClosestMunsellChip()", call. = FALSE) - the_chroma <- round(the_chroma) + # test Munsell chroma + if(any(! na.omit(the_chroma) %in% valid.chroma)) { + warning("non-standard notation in Munsell chroma, snapping to the nearest available chroma\n consider using getClosestMunsellChip()", call. = FALSE) + + ## TODO: optimize by only computing distances for non-standard Munsell chroma + + # snap supplied Munsell chroma to valid chroma via absolute distance + # NA are safely propagated + the_chroma <- .snapValid(the_chroma, valid.chroma) } + ## join new data with look-up table # note that value / chroma must be same data type as in `munsell` (numeric) d <- data.frame( @@ -371,15 +394,22 @@ munsell2rgb <- function(the_hue, the_value, the_chroma, alpha = 1, maxColorValue ) ## benchmarks: - # plyr::join 2x faster than base::merge - # data.table::merge (with conversion to/from) 5x faster than base::merge + # plyr::join() 2x faster than base::merge + # data.table::merge() (with conversion to/from) 5x faster than base::merge() + ## TODO: maybe more efficient with keys # round-trip through data.table is still faster d <- data.table::as.data.table(d) munsell <- data.table::as.data.table(munsell) + + + ## TODO: optimize by first filtering full lookup table on e.g. hue + + # join res <- merge(d, munsell, by = c('hue','value','chroma'), all.x = TRUE, sort = FALSE) + # back to data.frame res <- as.data.frame(res) @@ -405,8 +435,10 @@ munsell2rgb <- function(the_hue, the_value, the_chroma, alpha = 1, maxColorValue alpha <- maxColorValue } - # convert to R color - res$soil_color <- NA # init an empy column + + ## convert to hex notation + # init an empty column + res$soil_color <- NA # account for missing values if present: we have to do this because rgb() doesn't like NA if(length(rgb.na > 0)) { diff --git a/R/plotSPC.R b/R/plotSPC.R index 62b9a0d14..cd945bf8f 100644 --- a/R/plotSPC.R +++ b/R/plotSPC.R @@ -691,22 +691,7 @@ plotSPC <- function( hz.color.interpretation <- .interpretHorizonColor(h, color, default.color, col.palette, col.palette.bias, n.legend) h[['.color']] <- hz.color.interpretation$colors - # sketch parameters for follow-up overlay / inspection - lsp <- list('width' = width, - 'plot.order' = plot.order, - 'x0' = relative.pos + x.idx.offset, - 'pIDs' = pIDs[plot.order], - 'idname' = idname(x), - 'y.offset' = y.offset, - 'scaling.factor' = scaling.factor, - 'max.depth' = max.depth, - 'n' = n, - 'extra_x_space' = extra_x_space, - 'extra_y_space' = extra_y_space, - 'hz.depth.LAI' = rep(NA_real_, n), - 'legend.colors' = hz.color.interpretation$colors, - 'legend.data' = hz.color.interpretation$color.legend.data - ) + #################### @@ -722,36 +707,26 @@ plotSPC <- function( # get profile labels from @site pLabels <- site(x)[[label]] - ## this should probably use strwidth() AFTER plot() has been called - # if profile style is auto, determine style based on font metrics - if(id.style == 'auto') { - sum.ID.str.width <- sum(sapply(pLabels, strwidth, units='inches', cex=cex.id, font=2)) - plot.width <- par('pin')[1] - ID.width.ratio <- sum.ID.str.width / plot.width - # print(ID.width.ratio) - - if(ID.width.ratio > 0.7) - id.style <- 'side' - else - id.style <- 'top' - } + ####################################################################### + ## init plotting region, unless we are appending to an existing plot ## + ####################################################################### + + # y-limits also include y.offset range + ylim.range <- c( + max.depth + max(y.offset), + -extra_y_space + ) + + # x-limits + xlim.range <- c(width * x_left_space_mult, n + extra_x_space) - ## init plotting region, unless we are appending to an existing plot # note that we are using some fudge-factors to get the plotting region just right if(!add) { # margins are set outside of this function - # y-limits also include y.offset range - ylim.range <- c( - max.depth + max(y.offset), - -extra_y_space - ) - - # x-limits - xlim.range <- c(width * x_left_space_mult, n + extra_x_space) - + # make a new, empty plot plot(x = 0, y = 0, type = 'n', xlim = xlim.range, ylim = ylim.range, @@ -760,9 +735,72 @@ plotSPC <- function( } + + ######################## + ## device information ## + ######################## + + # note: all of this has to happen after plot(...), or if `add = TRUE` + + .par_usr <- par('usr') + .par_dev <- par('pin') + .par_xWidth <- diff(.par_usr[1:2]) + .par_devWidth <- .par_dev[1] + + # profiles / device width (inches) + .dev_sketch_density <- (.par_xWidth / .par_devWidth) + # calculate width of a single character on current plot device one.char.width <- strwidth('W') + + ################################ + ## profile ID style selection ## + ################################ + + # if profile style is auto, determine style based on font metrics + if(id.style == 'auto') { + sum.ID.str.width <- sum(sapply(pLabels, strwidth, units = 'inches', cex = cex.id, font = 2)) + ID.width.ratio <- sum.ID.str.width / .par_devWidth + + # debug + # print(ID.width.ratio) + + if(ID.width.ratio > 0.7) { + id.style <- 'side' + } + + else { + id.style <- 'top' + } + + } + + + ########################################################## + ## sketch parameters for follow-up overlay / inspection ## + ########################################################## + + lsp <- list('width' = width, + 'plot.order' = plot.order, + 'x0' = relative.pos + x.idx.offset, + 'pIDs' = pIDs[plot.order], + 'idname' = idname(x), + 'y.offset' = y.offset, + 'scaling.factor' = scaling.factor, + 'max.depth' = max.depth, + 'n' = n, + 'xlim' = xlim.range, + 'ylim' = ylim.range, + 'extra_x_space' = extra_x_space, + 'extra_y_space' = extra_y_space, + 'hz.depth.LAI' = rep(NA_real_, n), + 'legend.colors' = hz.color.interpretation$colors, + 'legend.data' = hz.color.interpretation$color.legend.data + ) + + + ## TODO dynamically adjust `width` based on strwidth(longest.hz.name) ## TODO abstract single profile sketch code into a single function ## TODO skip sketch rendering when i == `n` outside of length(SPC) (depths are NA) @@ -938,10 +976,13 @@ plotSPC <- function( if(truncation_flag_i & !all(is.na(xx))) { # must be an even number of oscillations - # computed as function of number of profiles + # computed as function of (ideal oscillations / 2) / sketch density # adjusted to width (n.osc increases with width) - # min value of 4 - .raggedN <- pmax(4, round((2.5 * width) * 32 / (n / 2)) * 2) + # min value of 6 + # max value of 32 + .raggedN <- round((2.5 * width) * (8 / .dev_sketch_density)) * 2 + .raggedN <- pmax(6, .raggedN) + .raggedN <- pmin(32, .raggedN) # ragged bottom line segment: lr -> ll ordering .r <- .raggedLines(x1 = x.ll, x2 = x.lr, y = y0[j], o = .raggedOffsets, n = .raggedN) @@ -1027,10 +1068,15 @@ plotSPC <- function( if(truncation_flag_i & !all(is.na(xx))) { # must be an even number of oscillations - # computed as function of number of profiles + # computed as function of (ideal oscillations / 2) / sketch density # adjusted to width (n.osc increases with width) - # min value of 4 - .raggedN <- pmax(4, round((2.5 * width) * 32 / (n / 2)) * 2) + # min value of 6 + # max value of 32 + .raggedN <- round((2.5 * width) * (8 / .dev_sketch_density)) * 2 + .raggedN <- pmax(6, .raggedN) + .raggedN <- pmin(32, .raggedN) + + ## TODO: allow user adjustments via argument # ragged bottom line segment: lr -> ll ordering .r <- .raggedLines(x1 = x.ll, x2 = x.lr, y = y0[j], o = .raggedOffsets, n = .raggedN) diff --git a/R/plot_distance_graph.R b/R/plot_distance_graph.R index c723d2596..aecea145d 100644 --- a/R/plot_distance_graph.R +++ b/R/plot_distance_graph.R @@ -15,7 +15,7 @@ #' @return No value is returned. #' @author Dylan E Beaudette #' @seealso \code{\link{sp2}}, \code{\link{profile_compare}} -#' @references http://casoilresource.lawr.ucdavis.edu/ +#' @references https://casoilresource.lawr.ucdavis.edu/ #' @keywords hplot #' @export #' @examples diff --git a/R/profile_compare.R b/R/profile_compare.R index eaddb0143..92fb9849f 100644 --- a/R/profile_compare.R +++ b/R/profile_compare.R @@ -71,10 +71,13 @@ #' @aliases pc pc.SPC profile_compare #' profile_compare,SoilProfileCollection-method #' profile_compare,data.frame-method +#' #' @docType methods -#' @param s a dataframe with at least 2 columns of soil properties, and an 'id' +#' +#' @param s a `data.frame` with at least 2 columns of soil properties, and an 'id' #' column for each profile. horizon depths must be integers and #' self-consistent, or a \code{SoilProfileCollection} object +#' #' @param vars A vector with named properties that will be used in the #' comparison. These are typically column names describing horizon-level #' attributes (2 or more), but can also contain site-level attributes (2 or @@ -105,7 +108,7 @@ #' optionally scaled by max(D). #' @author Dylan E. Beaudette -#' @seealso \code{\link{slice}}, \code{\link{daisy}} +#' @seealso [dice()], [cluster::daisy()] #' @references #' - D.E. Beaudette, P. Roudier, A.T. O'Geen, Algorithms for quantitative pedology: A toolkit for soil scientists, Computers & Geosciences, Volume 52, 2013, Pages 258-268, ISSN 0098-3004, \doi{10.1016/j.cageo.2012.10.020}. #' - Moore, A.; Russell, J. & Ward, W. Numerical analysis of soils: A comparison of three soil profile models with field classification. Journal of Soil Science, 1972, 23, 194-209. diff --git a/R/segment.R b/R/segment.R index 7b27e0ce0..dde1aefde 100644 --- a/R/segment.R +++ b/R/segment.R @@ -7,15 +7,16 @@ #' @param object either a `SoilProfileCollection` or `data.frame` #' @param intervals a vector of integers over which to slice the horizon data (e.g. `c(25, 100)` or `25:100`) #' @param trim logical, when `TRUE` horizons in `object` are truncated to the min/max specified in `intervals`. When `FALSE`, those horizons overlapping an interval are marked as such. Care should be taken when specifying more than one depth interval and `trim = FALSE`. -#' @param hzdepcols a character vector of length 2 specifying the names of the horizon depths (e.g. `c("hzdept", "hzdepb")`), only necessary if `object` is a `data.frame`. +#' @param depthcols a character vector of length 2 specifying the names of the horizon depths (e.g. `c("top", "bottom")`), only necessary if `object` is a +#' @param hzdepcols deprecated being replaced by depthcols. #' -#' @details `segment()` performs no aggregation or resampling of the source data, rather, labels are added to horizon records for subsequent aggregation or summary. This makes it possible to process a very large number of records outside of the constraints associated with e.g. `slice()` or `slab()`. +#' @details `hz_segment()` performs no aggregation or resampling of the source data, rather, labels are added to horizon records for subsequent aggregation or summary. This makes it possible to process a very large number of records outside of the constraints associated with e.g. `slice()` or `slab()`. #' #' @return Either a `SoilProfileCollection` or `data.frame` with the original horizon data segmented by depth intervals. There are usually more records in the resulting object, one for each time a segment interval partially overlaps with a horizon. A new column called `segment_id` identifying the depth interval is added. #' #' @author Stephen Roecker #' -#' @seealso [dice()], [glom()] +#' @seealso [dice()], [glom()], [hz_dissolve()], [hz_lag()], [hz_intersect()] #' #' @export #' @@ -28,7 +29,7 @@ #' depths(sp1) <- id ~ top + bottom #' #' # segment and trim -#' z <- segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE) +#' z <- hz_segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE) #' #' # display segment labels #' # note that there are new horizon boundaries at segments @@ -52,7 +53,7 @@ #' #' a.slab <- slab(s, fm = ~ p1, slab.structure = c(0, 10, 20, 30), slab.fun = mean, na.rm = TRUE) #' -#' z <- segment(s, intervals = c(0, 10, 20, 30), trim = TRUE) +#' z <- hz_segment(s, intervals = c(0, 10, 20, 30), trim = TRUE) #' z <- horizons(z) #' z$thick <- z$bottom - z$top #' @@ -75,22 +76,22 @@ #' data(sp5) #' #' # segment by upper 25-cm -#' test1 <- segment(sp5, intervals = c(0, 100)) +#' test1 <- hz_segment(sp5, intervals = c(0, 100)) #' print(test1) #' nrow(test1) #' print(object.size(test1), units = "Mb") #' #' # segment by 1-cm increments -#' test2 <- segment(sp5, intervals = 0:100) +#' test2 <- hz_segment(sp5, intervals = 0:100) #' print(test2) #' nrow(test2) #' print(object.size(test2), units = "Mb") #' #' #' # segment and aggregate -#' test3 <- segment(horizons(sp5), +#' test3 <- hz_segment(horizons(sp5), #' intervals = c(0, 5, 15, 30, 60, 100, 200), -#' hzdepcols = c("top", "bottom") +#' depthcols = c("top", "bottom") #' ) #' test3$hzthk <- test3$bottom - test3$top #' test3_agg <- by(test3, test3$segment_id, function(x) { @@ -104,99 +105,98 @@ #' #' head(test3_agg) #' -segment <- function(object, intervals, trim = TRUE, hzdepcols = NULL) { - +hz_segment <- function(object, intervals, trim = TRUE, depthcols = c("top", "bottom")) { + # depth interval rules dep <- data.frame( top = intervals[-length(intervals)], bot = intervals[-1], stringsAsFactors = FALSE ) + n <- max(nchar(intervals)) - dep$id <- paste0( - formatC(dep$top, width = n, flag = 0), - "-", - formatC(dep$bot, width = n, flag = 0) - ) + dep$id <- paste0(formatC(dep$top, width = n, flag = 0), + "-", + formatC(dep$bot, width = n, flag = 0)) - # argument sanity check + # argument sanity check ---- test_spc <- inherits(object, 'SoilProfileCollection') test_df <- inherits(object, 'data.frame') - test_hd <- !is.null(hzdepcols) & length(hzdepcols) == 2 test_dep <- is.numeric(dep$top) & is.numeric(dep$bot) & all(dep$top < dep$bot) - if (!any(test_spc, test_df)) { stop("the input must be either a SoilProfileCollection or data.frame") } - if (!test_spc & (!test_df | !test_hd)) { - stop("if the input is a data.frame then hzdepcols must not be NULL and length(hzdepcols) == 2") - } + .check_depthcols_l(depthcols) if (!test_dep) { stop("intervals should be numeric and sequential (e.g. c(0, 1, 2, 3) or 0:100)") } - - # standardize inputs + # standardize inputs ---- if (test_spc) { - peid <- idname(object) - hzid <- hzidname(object) - hzdepcols <- horizonDepths(object) + idcol <- idname(object) + hzidcol <- hzidname(object) + depthcols <- horizonDepths(object) h <- horizons(object) - names(h)[names(h) %in% c(peid, hzid)] <- c("peid", "hzid") + names(h)[names(h) %in% c(idcol, hzidcol)] <- c("idcol", "hzidcol") } else { h <- object } - names(h)[names(h) %in% hzdepcols] <- c("hzdept", "hzdepb") + names(h)[names(h) %in% depthcols] <- c("top", "bot") ## TODO: consider using dice() - # filter horizons and trim + # filter horizons and trim ---- .slice <- function(h, top = NULL, bot = NULL) { - idx <- h$hzdept <= bot & h$hzdepb >= top + idx <- which(h$top < bot & h$bot > top) h <- h[idx, ] - # causing errors when FALSE + # causing errors when FALSE; fixed? if (trim == TRUE) { - h <- within(h, { - hzdept = ifelse(hzdept < top, top, hzdept) - hzdepb = ifelse(hzdepb > bot, bot, hzdepb) - }) + h$top = ifelse(h$top < top, top, h$top) + h$bot = ifelse(h$bot > bot, bot, h$bot) - h <- h[(h$hzdepb - h$hzdept) > 0, ] + # h <- h[(h$bot - h$top) > 0, ] } + # h <- h[!is.na(h$peiid), ] + return(h) } - # slice spc by intervals + # slice spc by intervals ---- # dep$df <- lapply(1:nrow(dep), function(x) h[0, ]) # pre-allocate memory - dep$df <- list(h[0, ])[rep(1, nrow(dep))] # pre-allocate memory faster + df_str <- cbind(h[0, ], segment_id = NA_character_[0]) + dep$df <- list(df_str)[rep(1, nrow(dep))] # pre-allocate memory faster h <- { - split(dep, dep$id) ->.; + split(dep, dep$id) -> . + lapply(., function(x) { - x$df[[1]] <- cbind(.slice(h, top = x$top, bot = x$bot), segment_id = x$id) + temp <- .slice(h, top = x$top, bot = x$bot) + if (nrow(temp) > 0) + x$df[[1]] <- cbind(temp, segment_id = x$id) return(x$df[[1]]) - }) ->.; - do.call("rbind", .) ->.; - } - names(h)[names(h) %in% c("hzdept", "hzdepb")] <- hzdepcols + }) -> . + + do.call("rbind", .) -> . + } + names(h)[names(h) %in% c("top", "bot")] <- depthcols if (test_spc) { - h <- h[order(h$peid, h[[hzdepcols[1]]]), ] + h <- h[order(h$idcol, h[[depthcols[1]]]), ] # merge to re-add spc with NA - h_orig <- data.frame(peid = names(table(horizons(object)[peid])), stringsAsFactors = FALSE) - h <- merge(h_orig, h, by = "peid", all.x = TRUE, sort = FALSE) + h_orig <- data.frame(idcol = names(table(horizons(object)[idcol])), stringsAsFactors = FALSE) + h <- merge(h_orig, h, by = "idcol", all.x = TRUE, sort = FALSE) rm(h_orig) ## TODO: consider adding a flag to indicate "new" horizon records that have been added - # rebuild SPC - names(h)[names(h) == "peid"] <- peid - names(h)[names(h) == "hzid"] <- hzid + # rebuild SPC ---- + names(h)[names(h) == "idcol"] <- idcol + names(h)[names(h) == "hzidcol"] <- hzidcol h$hzID <- 1:nrow(h) replaceHorizons(object) <- h @@ -212,6 +212,12 @@ segment <- function(object, intervals, trim = TRUE, hzdepcols = NULL) { } +#' @export +#' @rdname hz_segment +segment <- function(object, intervals, trim = TRUE, hzdepcols = c("top", "bottom")) { + .Deprecated("segment() is deprecated and has been replaced by hz_segment()") + hz_segment(object, intervals, trim, depthcols = hzdepcols) +} #' @title Dissolving horizon boundaries by grouping variables #' @@ -219,19 +225,21 @@ segment <- function(object, intervals, trim = TRUE, hzdepcols = NULL) { #' #' @param object a \code{data.frame} #' @param by character: column names, to be used as grouping variables, within the object. -#' @param id character: column name of the pedon ID within the object. -#' @param hztop character: column name of the horizon top depth within the object. -#' @param hzbot character: column name of the horizon bottom depth in the object. +#' @param idcol character: column name of the pedon ID within the object. +#' @param depthcols a character vector of length 2 specifying the names of the horizon depths (e.g. `c("top", "bottom")`). +#' @param id deprecated and replaced with idcol. +#' @param hztop deprecated and replaced by depthcols. +#' @param hzbot deprecated and replaced by depthcols. #' @param collapse logical: indicating whether to not combine grouping variables before dissolving. #' @param order logical: indicating whether or not to order the object by the id, hztop, and hzbot columns. -#' #' +#' #' @details This function assumes the profiles and horizons within the object follow the logic defined by \code{checkHzDepthLogic} (e.g. records are ordered sequentially by id, hztop, and hzbot and without gaps). If the records are not ordered, set the \code{order = TRUE}. #' -#' @return A \code{data.frame} with the original id, by grouping variables, and non-consecutive horizon depths. +#' @return A \code{data.frame} with the original idcol, by grouping variables, and non-consecutive horizon depths. #' #' @author Stephen Roecker #' -#' @seealso \code{\link{checkHzDepthLogic}} +#' @seealso [hz_lag()], [hz_intersect()], [hz_segment()] , [checkHzDepthLogic()] #' #' @export #' @@ -245,7 +253,7 @@ segment <- function(object, intervals, trim = TRUE, hzdepcols = NULL) { #' spc$genhz <- generalize.hz(spc$name, c("A", "E", "B", "C"), c("A", "E", "B", "C")) #' h <- horizons(spc) #' -#' test <- dissolve_hz(h, by = c("genhz", "dep_5"), id = "id", hztop = "top", hzbot = "bottom") +#' test <- hz_dissolve(h, by = c("genhz", "dep_5"), idcol = "id", depthcols = c("top", "bottom")) #' #' vars <- c("id", "top", "bottom", "genhz", "dep_5") #' h[h$id == "92-1", vars] @@ -254,9 +262,9 @@ segment <- function(object, intervals, trim = TRUE, hzdepcols = NULL) { #' #' # example 2 #' df <- data.frame( -#' peiid = 1, -#' hzdept = c(0, 5, 10, 15, 25, 50), -#' hzdepb = c(5, 10, 15, 25, 50, 100), +#' id = 1, +#' top = c(0, 5, 10, 15, 25, 50), +#' bottom = c(5, 10, 15, 25, 50, 100), #' hzname = c("A1", "A2", "E/A", "2Bt1", "2Bt2", "2C"), #' genhz = c("A", "A", "E", "2Bt", "2Bt", "2C"), #' texcl = c("sil", "sil", "sil", "sl", "sl", "s") @@ -264,15 +272,13 @@ segment <- function(object, intervals, trim = TRUE, hzdepcols = NULL) { #' #' df #' -#' dissolve_hz(df, c("genhz", "texcl")) -#' dissolve_hz(df, c("genhz", "texcl"), collapse = TRUE) +#' hz_dissolve(df, c("genhz", "texcl")) +#' hz_dissolve(df, c("genhz", "texcl"), collapse = TRUE) #' -#' test <- dissolve_hz(df, "genhz") +#' test <- hz_dissolve(df, "genhz") #' subset(test, value == "2Bt") #' - - -dissolve_hz <- function(object, by, id = "peiid", hztop = "hzdept", hzbot = "hzdepb", collapse = FALSE, order = FALSE) { +hz_dissolve <- function(object, by, idcol = "id", depthcols = c("top", "bottom"), collapse = FALSE, order = FALSE) { # id = "peiid"; hztop = "hzdept"; hzbot = "hzdepb", collapse = FALSE, order = FALSE @@ -281,26 +287,18 @@ dissolve_hz <- function(object, by, id = "peiid", hztop = "hzdept", hzbot = "hzd # test_spc <- inherits(object, 'SoilProfileCollection') # check that object & by are the right class - test_object <- inherits(object, "data.frame") - test_by <- inherits(by, "character") - - if (!any(test_object | test_by)) { - stop("the object argument must be a data.frame, and by a character", call. = FALSE) + test_object <- inherits(object, "data.frame") + if (!any(test_object)) { + stop("the object argument must be a data.frame", call. = FALSE) } - # check that by is not NULL - if (is.null(by)) stop("the by argument must not be NULL") - # check that collapse is a logical of length 1 if (!inherits(collapse, "logical") || length(collapse) != 1) { stop("the collapse argument must be logical and a length of one", call. = FALSE) } - # check that the column names exisit within the object - var_names <- c(id = id, top = hztop, bot = hzbot, by) - if (!all(var_names %in% names(object))) { - stop("all arguments must match object names") - } + # check that by is not NULL + if (is.null(by)) stop("the by argument must not be NULL") # check that "by" are characters or convert if (any(!"character" %in% sapply(object[by], class))) { @@ -308,15 +306,27 @@ dissolve_hz <- function(object, by, id = "peiid", hztop = "hzdept", hzbot = "hzd object[by] <- lapply(object[by], as.character) } + # check that the column names exist within the object + .check_names(object, vars = c(idcol = idcol, top = depthcols[1], bot = depthcols[2], by)) + + # check if previous dissolve_id exists and overwrite + nm <- names(object) + idx <- nm == "dissolve_id" + if (any(idx)) { + warning("object contains an existing column named 'dissolve_id', it will be overwritten") + object[idx] <- NULL + } + # standardize inputs ---- - df <- object - idx_names <- sapply(var_names[1:3], function(x) which(names(df) == x)) - names(df)[idx_names] <- names(var_names)[1:3] + df_std <- .standardize_inputs(object, idcol = idcol, depthcols = depthcols) + df_conversion <- df_std$x_conversion + df <- df_std$x; rm(df_std) + # valid # vd_idx <- validate_depths(df, id = "id", hztop = "hzdept", bot = "hzdepb") if (order == TRUE) { - df <- df[order(df$id, df$top, df$bot), ] + df <- df[order(df$idcol, df$top, df$bot), ] } if (collapse == TRUE) { @@ -328,27 +338,373 @@ dissolve_hz <- function(object, by, id = "peiid", hztop = "hzdept", hzbot = "hzd # var thickness ---- var_dep <- lapply(by, function(x) { - con_bot <- rle( paste(df$id, df[, x]))$length - con_top <- rle(rev(paste(df$id, df[, x])))$length + con_bot <- rle( paste(df$idcol, df[, x]))$length + con_top <- rle(rev(paste(df$idcol, df[, x])))$length bot_idx <- cumsum(con_bot) top_idx <- cumsum(con_top) vd <- data.frame( - id = df[bot_idx, "id"], - top = rev(rev(df$top)[top_idx]), - bot = df[bot_idx, "bot"], + idcol = df[bot_idx, "idcol"], + top = rev(rev(df$top)[top_idx]), + bot = df[bot_idx, "bot"], variable = x, - value = df[bot_idx, x] + value = df[bot_idx, x] ) + # vd$dissolve_id = 1:nrow(vd) return(vd) }) var_dep <- do.call("rbind", var_dep) - # undo standardization ---- - names(var_dep)[1:3] <- var_names[1:3] + # this is redundant with collapse = TRUE, and inappropriate unless the grouping by variable matches across all horizon depths, otherwise it'll generate pedons with overlapping depths + # if (direction == "wide") { + # var_dep <- reshape( + # var_dep, + # direction = "wide", + # idvar = c("id", "top", "bot"), + # timevar = "variable", + # v.names = "value" + # ) + # } + + # append dissolve_id + n <- max(nchar(c(var_dep$top, var_dep$bot)), na.rm = TRUE) + + var_dep$dissolve_id <- paste0( + var_dep$idcol, + "_", + formatC(var_dep$top, width = n, flag = 0), + "-", + formatC(var_dep$bot, width = n, flag = 0), + "_", + var_dep$value + ) + + + # reset inputs ---- + var_dep <- .reset_inputs(var_dep, df_conversion) return(var_dep) } + + +#' @export +#' @rdname hz_dissolve + +dissolve_hz <- function(object, by, id = "idcol", hztop = "top", hzbot = "bottom", collapse = FALSE, order = FALSE) { + .Deprecated("dissolve_hz() is deprecated and has been replaced by hz_dissolve()") + hz_dissolve(object, by, idcol = id, depthcols = c(hztop, hzbot), collapse, order) +} + + + +#' @title Intersecting horizon boundaries by horizon depths +#' +#' @description This function intersects two horizon tables by harmonizing their depths and merging them where they overlap. This can be useful to rejoin the results of `hz_dissolve()` to it's original horizon table, and then perform an aggregation on the dissolved variables. +#' +#' @param x a \code{data.frame} +#' @param y a \code{data.frame} +#' @param idcol character: column name of the pedon ID within the object. +#' @param depthcols a character vector of length 2 specifying the names of the horizon depths (e.g. `c("top", "bottom")`). +#' +#' @details . +#' +#' @return A \code{data.frame} with harmonized depth intervals (i.e. segment_id) and columns from both of the original \code{data.frame}. If both \code{data.frame} contain the same column names, they will both be returned (with the exception of the idcol and depthcols), and appended with either x or y to indicate which \code{data.frame} they originated from. +#' +#' @author Stephen Roecker +#' +#' @seealso [hz_dissolve()], [hz_lag()], [hz_segment()] +#' +#' @export +#' +#' @examples +#' +#' h <- data.frame( +#' id = 1, +#' top = c(0, 25, 44, 46, 50), +#' bottom = c(25, 44, 46, 50, 100), +#' by = c("Yes", "Yes", "No", "No", "Yes"), +#' clay = c(10, 12, 27, 35, 16) +#' ) +#' +#' hz_dissolve(h, "by") +#' +#' hz_intersect(x = hz_dissolve(h, "by"), y = h) +#' +#' hi <- hz_intersect(x = h, y = hz_dissolve(h, "by")) +#' aggregate(clay ~ dissolve_id, data = hi, mean) +#' +hz_intersect <- function(x, y, idcol = "id", depthcols = c("top", "bottom")) { + + # test inputs ---- + # argument sanity check + + # check that depthcols ---- + ## length == 2 + if (length(depthcols) != 2) stop("depthcols must length must equal 2") + + ## check for matching column names + .check_names(x, c(idcol, depthcols)) + .check_names(y, c(idcol, depthcols)) + + # check segment_id ---- + ## if it exists, overwrite it + x_nm <- names(x) + y_nm <- names(y) + if (any(x_nm %in% "segment_id")) { + warning("x includes a column named 'segment_id', it will be overwritten") + x[x_nm == "segment_id"] <- NULL + } + + if (any(y_nm %in% "segment_id")) { + warning("y includes a column named 'segment_id', it will be overwritten") + y[y_nm == "segment_id"] <- NULL + } + + # standardize inputs ---- + x_std <- .standardize_inputs(x, idcol = idcol, depthcols = depthcols) + x_conversion <- x_std$x_conversion + x <- x_std$x; rm(x_std) + + y <- .standardize_inputs(y, idcol = idcol, depthcols = depthcols)$x + + # intersect x & y ---- + res <- lapply(split(x, x$idcol), function(x) { + xi <- x + yi <- y[which(y$idcol == xi$idcol[1]), ] + + if (nrow(yi) > 0) { + + int <- unique(sort(c(xi$top, xi$bot, yi$top, yi$bot))) + + xi_seg <- hz_segment(xi, intervals = int, depthcols = names(x_conversion[2:3]), trim = TRUE) + yi_seg <- hz_segment(yi, intervals = int, depthcols = names(x_conversion[2:3]), trim = TRUE) + + return(list(x_seg = xi_seg, y_seg = yi_seg)) + } + }) + + x_seg <- do.call("rbind", lapply(res, function(x) x[["x_seg"]])) + y_seg <- do.call("rbind", lapply(res, function(x) x[["y_seg"]])) + + xy_int <- merge(x_seg, y_seg, by = c("segment_id", "idcol", "top", "bot"), sort = FALSE) + + # reset inputs ---- + xy_int <- .reset_inputs(xy_int, x_conversion) + + return(xy_int) +} + + + +#' @title Find lagged horizon values +#' +#' @description This function finds adjacent values to a horizon values at lagged distances. +#' +#' @param object a \code{data.frame} +#' @param lag integer: number of horizons to lag +#' @param unit character: lag units in index or depth. +#' @param idcol character: column name of the pedon ID within the object. +#' @param depthcols a character vector of length 2 specifying the names of the horizon depths (e.g. `c("top", "bottom")`). +#' @param order logical: indicating whether or not to order the #' +#' @details . +#' +#' @return A \code{data.frame} with lagged values. +#' +#' @author Stephen Roecker +#' +#' @seealso [hz_dissolve()], [hz_intersect()], [hz_segment()] +#' +#' @export +#' +#' @examples +#' +#' h <- data.frame( +#' id = 1, +#' top = c(0, 25, 44, 46, 50), +#' bottom = c(25, 44, 46, 50, 100), +#' texcl = c("SL", "SL", "CL", "CL", "L"), +#' clay = c(10, 12, 27, 35, 16) +#' ) +#' +#' hz_lag(h) +#' +#' hz_lag(h, -1) +#' +#' hz_lag(h, 10:15, unit = "depth") +#' +#' transform(cbind(h, lag = hz_lag(h)), +#' clay_dif = lag.clay_bot.1 - clay, +#' texcl_contrast = paste0(texcl, "-", lag.texcl_bot.1) +#' ) +#' +hz_lag <- function(object, lag = 1, unit = "index", idcol = "id", depthcols = c("top", "bottom"), order = FALSE) { + + nm <- names(object) + idx_std <- which(! nm %in% c(idcol, depthcols)) + vars <- nm[idx_std] + + # check arguments ---- + .check_depthcols_l(depthcols) + .check_names(object, vars = c(idcol, depthcols, vars)) + + # standardize inputs ---- + x_std <- .standardize_inputs(object, idcol = idcol, depthcols = depthcols) + x_conversion <- x_std$x_conversion + x <- x_std$x + rm(x_std) + + # check depths --- + if (unit == "depth" & max(object[[depthcols[2]]] > 1000)) { + warning("The maximum depth is greater than 1000, which is implausible and will be removed. To avoid this action either remove the offending horizon or convert the depth units to a measure which will not exceed 1000") + x <- x[x$bot < 1000, ] + } + + test <- max(aggregate(top ~ idcol, data = x, length)$top) + if (unit == "index") { + if ((test - 1) < max(lag)) { + stop("lag can not be greater than the maximum number of horizons") + } + } + + # order ---- + if (order) { + x <- x[order(x$idcol, x$top, x$bot), ] + } + + # lag ---- + .lag_ind <- function(x, lag = lag) { + + nr <- nrow(x) + top <- 1:nr + if (lag >= 0) bot <- c((1 + lag):nr, rep(NA, lag)) + if (lag < 0) bot <- c(rep(NA, abs(lag)), 1:(nr + lag)) + + test_idcol <- x$idcol[top] == x$idcol[bot] + test_idcol <- ifelse(! test_idcol, NA, TRUE) + x_lag <- x[test_idcol * bot, vars] + if (lag >= 0) names(x_lag) <- paste0(vars, "_bot.", lag) + if (lag < 0) names(x_lag) <- paste0(vars, "_top.", abs(lag)) + + return(x_lag) + } + + .lag_dep <- function(x, lag = lag) { + + n <- length(x) + x$.ID <- 1:nrow(x) + x_seg <- hz_segment(x, intervals = min(x$top):max(x$bot), trim = TRUE, depthcols = c("top", "bot")) + x_seg <- x_seg[1:(n + 1)] + + x_seg <- do.call("cbind", args = lapply(lag, function(i) { + x$bot_i <- x$bot + i + idx <- match(paste(x$idcol, x$bot_i), + paste(x_seg$idcol, x_seg$bot)) + xi_seg <- x_seg[idx,] + xi_seg <- x[xi_seg$.ID, vars, drop = FALSE] + xi_seg$.ID <- NULL + + if (i >= 0) + names(xi_seg) <- paste0(names(xi_seg), "_bot.", i) + + if (i < 0) + names(xi_seg) <- paste0(names(xi_seg), "_top.", abs(i)) + + return(xi_seg) + })) + + return(x_seg) + } + + if (unit == "index") { + x_lag <- do.call("cbind", lapply(lag, function(i) { + .lag_ind(x, i) + })) + x_lag <- x_lag[sort(names(x_lag))] + } + + if (unit == "depth") { + x_lag <- .lag_dep(x, lag) + x_lag <- x_lag[sort(names(x_lag))] + } + + # # reset inputs ---- + x_lag <- .reset_inputs(x_lag, x_conversion) + + return(x_lag) +} + +# check depthcols length +.check_depthcols_l <- function(x) { + if (length(x) != 2 & !is.null(x)) stop("depthcols must length must equal 2") +} + +## check for matching column names +.check_names <- function(x, vars) { + x_nm <- names(x) + + if (!all(vars %in% x_nm)) { + stop("x must contain columns with names that match the input arguments") + } +} + +# standardize inputs +.standardize_inputs <- function( + x, + idcol = NULL, + hzidcol = NULL, + depthcols = NULL, + texcl = NULL, + clay = NULL, + taxpartsize = NULL, + sand = NULL +) { + + # set new names + var_names <- c( + idcol = idcol, + hzidcol = hzidcol, + top = depthcols[1], + bot = depthcols[2], + texcl = texcl, + clay = clay, + sand = sand, + taxpartsize = taxpartsize + ) + + # find matches + idx_x <- sapply(var_names, function(i) which(names(x) == i)) + + # rename matching column names + names(x)[idx_x] <- names(var_names) + + # remove duplicate names + nm_x <- names(x) + idx_dup <- names(which(table(nm_x) > 1)) + idx_dup <- which(nm_x %in% idx_dup) + if (any(!is.na(idx_dup))) { + warning("some argument names are duplicated by the function column name harmonization and will be renamed to var_orig (e.g. clay_orig)") + + idx_orig <- idx_dup[! idx_dup %in% idx_x] + names(x)[idx_orig] <- paste0(names(x)[idx_orig], "_orig") + } else { + idx_orig <- NULL + } + + return(list(x = x, x_conversion = var_names, x_orig = idx_orig)) +} + + +.reset_inputs <- function(x, conversion) { + + # find original names + idx <- which(names(x) %in% names(conversion)) + + # reset original names + names(x)[idx] <- conversion + + return(x) +} + diff --git a/R/simulateColor.R b/R/simulateColor.R index 7658a790a..d94842ebb 100644 --- a/R/simulateColor.R +++ b/R/simulateColor.R @@ -1,4 +1,59 @@ +## simulate via multivariate normal distribution +# n: number of simulations (typically horizons) +# parameters: list of parameters +# data.frame with Munsell [hue, value, chroma] +.simulateColorFromMV <- function(n, parameters) { + + # sanity check, need this for rmvnorm() + if(!requireNamespace('mvtnorm')) { + stop('package `mvtnorm` is required for multivariate simulation', call. = FALSE) + } + + ## TODO: consider pre-estimated mean vector + covariance matrix + + # extract parameters + .hvc <- parameters[['hvc']] + + # convert Munsell -> CIELAB + .lab <- munsell2rgb(the_hue = .hvc$hue, the_value = .hvc$value, the_chroma = .hvc$chroma, returnLAB = TRUE) + + # removing missing values which interfere with mean and covariance + .lab <- na.omit(.lab) + + ## TODO: stop if nrow(.lab) < 3 + if(nrow(.lab) < 3) { + return(NULL) + } + + # multivariate simulation + # assuming approx. joint normal distribution over L, A, B coordinates + s <- mvtnorm::rmvnorm( + n = n, + mean = colMeans(.lab), + sigma = cov(.lab), + ) + + + ## TODO: consider returning CIELAB coordinates + # .cols <- convertColor(s, from = 'Lab', to = 'sRGB', from.ref.white = 'D65', to.ref.white = 'D65') + # previewColors(rgb(.cols, maxColorValue = 1), method = 'MDS') + + # this is slow + # CIELAB -> Munsell hue, value, chroma + m <- col2Munsell(s, space = 'CIELAB') + + ## TODO: consider including only hues in reference set + + # flatten to standard notation + m <- sprintf('%s %s/%s', m$hue, m$value, m$chroma) + + return(m) +} + + + + ## simulate color via sampling with replacement and estimated proportions # n: number of simulations (typically horizons) # parameters: output from aqp::aggregateColor() @@ -54,7 +109,7 @@ cc <- colorContrast(x$munsell, rep(m$queryColor, times = nrow(x))) # join for plotting - z <- merge(x, cc, by.x='munsell', by.y='m1', all.x=TRUE, sort=FALSE) + z <- merge(x, cc, by.x = 'munsell', by.y = 'm1', all.x = TRUE, sort = FALSE) # dE00 threshold idx <- which(z$dE00 < thresh) @@ -69,12 +124,12 @@ } - ## TODO: think about alternatives - - # ? --> perform conversion without RV, then re-add just before sampling - # z <- z[z$munsell != m$queryColor, ] + ## TODO: think about alternatives: + # + # * ? --> perform conversion without RV, then re-add just before sampling + # * z <- z[z$munsell != m$queryColor, ] - # convert distances -> similarities + ## convert distances -> similarities, interpret as sampling weights # standard conversion # too fast of a drop off between RV and simulated values @@ -84,16 +139,15 @@ # simulated values too close to RV # s <- 1 - (z$dE00 / max(z$dE00)) - ## according to ?sample there is no need to convert weights -> probabilities - - # ## diagnostics for dE00 -> probability + ## diagnostics for dE00 -> probability # plot(s, z$dE00, type = 'n', las = 1) # points(s, z$dE00, col = z$color, pch = 15) # text(s, 0, z$munsell, cex = 0.5, srt = 90) # sample with replacement + # according to ?sample, there is no need to convert weights -> probabilities # using translated dE00 as prior probabilities res <- sample(z$munsell, replace = TRUE, size = n, prob = s) @@ -105,17 +159,25 @@ #' @title Simulate Soil Colors #' -#' @description Simulate plausible soil colors based on proportions by Munsell "chip", or using a seed Munsell chip and threshold specified via CIE2000 color contrast metric. +#' @description Simulate plausible soil colors based on several possible parameterization of a "range in characteristics" (RIC). Soil color RIC can be specified by a list of parameters: +#' * soil color proportions, as output from [aggregateColor()] -- `method = 'proportions'` +#' * most likely Munsell color, CIE2000 threshold, and vector of acceptable hues -- `method = 'dE00'` +#' * `data.frame` of Munsell hue, value, and chroma representing observed soil colors -- `method = 'mvnorm'` +#' +#' #' #' @author D.E. Beaudette #' #' @param method simulation method, see details -#' @param n number of simulated colors per horizon +#' +#' @param n number of simulated colors per group +#' #' @param parameters a `list`, format depends on `method`: -#' * `proportions`: output from [`aggregateColor`] +#' * `proportions`: output from [aggregateColor()] #' * `dE00`: formatted as `list(m = '7.5YR 3/3', thresh = 5, hues = c('7.5YR'))` +#' * `mvnorm`: formatted as `list(hvc = x)` #' -#' Where `m` is a single representative Munsell chip, `thresh` is a threshold specified in CIE2000 color contrast (dE00), and `hues` is a vector of allowed Munsell hues. +#' Where `m` is a single representative Munsell chip, `thresh` is a threshold specified in CIE2000 color contrast (dE00), `hues` is a vector of allowed Munsell hues, and `x` is a `data.frame` representing columns of Munsell hue, value, and chroma having at least 3 rows. #' #' @param SPC `SoilProfileCollection`, attempt to modify `SPC` with simulated colors #' @@ -167,7 +229,7 @@ #' # what does a dE00 threshold look like on 3 pages of hue? #' contrastChart('7.5YR 3/3', hues = c('10YR', '7.5YR', '5YR'), thresh = 20) #' -simulateColor <- function(method = c('dE00', 'proportions'), n, parameters, SPC = NULL) { +simulateColor <- function(method = c('dE00', 'proportions', 'mvnorm'), n, parameters, SPC = NULL) { # safely select method method <- match.arg(method) @@ -177,15 +239,26 @@ simulateColor <- function(method = c('dE00', 'proportions'), n, parameters, SPC parameters <- list(parameters) } + ## TODO: basic error checking, depends on method + + # select method res <- switch( method, 'dE00' = { + # manual iteration over parameters lapply(parameters, function(i) { .simulateColorFromDE00(n = n, parameters = i) }) }, + # automatic iteration over output from aggregateColor() 'proportions' = { .simulateColorFromProportions(n = n, parameters = parameters) + }, + # manual iteration over parameters + 'mvnorm' = { + lapply(parameters, function(i) { + .simulateColorFromMV(n = n, parameters = i) + }) } ) @@ -194,7 +267,7 @@ simulateColor <- function(method = c('dE00', 'proportions'), n, parameters, SPC return(res) } else { - ## TODO: make this mor efficient + ## TODO: make this more efficient # result is a modified SPC @@ -214,6 +287,5 @@ simulateColor <- function(method = c('dE00', 'proportions'), n, parameters, SPC return(combine(l)) } - } diff --git a/R/soilColorIndices.R b/R/soilColorIndices.R index 0806bd8ba..500c7bed3 100644 --- a/R/soilColorIndices.R +++ b/R/soilColorIndices.R @@ -137,7 +137,7 @@ barron.torrent.redness.LAB <- function(hue, value, chroma) { #' jacobs2000$rubif <- profileApply(jacobs2000, function(p) { #' #' # sum the melanization index over the 0-100cm interval -#' p0_100 <- segment(p, 0:100) +#' p0_100 <- hz_segment(p, 0:100) #' #' ccol <- parseMunsell(p$c_horizon_color, convertColors = FALSE) #' @@ -227,7 +227,7 @@ harden.rubification <- function(hue, chroma, hue_ref, chroma_ref) { #' jacobs2000$melan <- profileApply(jacobs2000, function(p) { #' #' # sum the melanization index over the 0-100cm interval -#' p0_100 <- segment(p, 0:100) +#' p0_100 <- hz_segment(p, 0:100) #' #' ccol <- parseMunsell(p$c_horizon_color, convertColors = FALSE) #' @@ -300,7 +300,7 @@ buntley.westin.index <- function(hue, chroma) { #' @rdname thompson.bell.darkness #' @export thompson.bell.darkness thompson.bell.darkness <- function(p, - name = guessHzDesgnName(p, required = TRUE), + name = hzdesgnname(p, required = TRUE), pattern = "^A", value = "m_value", chroma = "m_chroma") { @@ -310,8 +310,9 @@ thompson.bell.darkness <- function(p, hz <- horizons(p) depthz <- horizonDepths(p) - if (!all(name %in% horizonNames(p))) { - name <- guessHzDesgnName(p, required = TRUE) + + if (is.null(name) || !name %in% horizonNames(p)) { + stop("Horizon designation column (", name, ") does not exist.") } a.hz <- hz[grepl(hz[[name]], pattern = pattern),] diff --git a/R/texture.R b/R/texture.R index 6be5cb168..bc803348c 100644 --- a/R/texture.R +++ b/R/texture.R @@ -70,6 +70,8 @@ #' #' @return - `texcl_to_ssc`: A `data.frame` containing columns `"sand"`,`"silt"`, `"clay"` #' +#' @seealso \code{\link{SoilTextureLevels}} +#' #' @author Stephen Roecker #' #' @references Matthew R. Levi, Modified Centroid for Estimating Sand, Silt, and Clay from Soil Texture Class, Soil Science Society of America Journal, 2017, 81(3):578-588, ISSN 1435-0661, \doi{10.2136/sssaj2016.09.0301}. @@ -159,6 +161,15 @@ texcl_to_ssc <- function(texcl = NULL, clay = NULL, sample = FALSE) { load(system.file("data/soiltexture.rda", package="aqp")[1]) + + + # convert fine sand classes to their generic counterparts + df <- within(df, { + texcl = ifelse(texcl %in% c("cos", "fs", "vfs"), "s", texcl) + texcl = ifelse(texcl %in% c("lcos", "lfs", "lvfs"), "ls", texcl) + texcl = ifelse(texcl %in% c("cosl", "fsl", "vfsl"), "sl", texcl) + }) + # check for texcl that don't match @@ -175,7 +186,12 @@ texcl_to_ssc <- function(texcl = NULL, clay = NULL, sample = FALSE) { idx <- paste(df$texcl[clay_not_na], df$clay[clay_not_na]) %in% paste(soiltexture$values$texcl, soiltexture$values$clay) if (any(!idx)) { - warning("not all the user supplied clay values fall within the texcl") + warning("not all the user supplied clay values fall within the texcl, so they will be set to NA") + + df$clay[which(!idx)] <- NA + + clay_not_null <- all(!is.na(df$clay)) + clay_is_null <- !clay_not_null } } @@ -187,14 +203,6 @@ texcl_to_ssc <- function(texcl = NULL, clay = NULL, sample = FALSE) { } - # convert fine sand classes to their generic counterparts - df <- within(df, { - texcl = ifelse(texcl %in% c("cos", "fs", "vfs"), "s", texcl) - texcl = ifelse(texcl %in% c("lcos", "lfs", "lvfs"), "ls", texcl) - texcl = ifelse(texcl %in% c("cosl", "fsl", "vfsl"), "sl", texcl) - }) - - # if clay is present if (clay_not_null & sample == FALSE) { @@ -413,16 +421,19 @@ texmod_to_fragvoltot <- function(texmod = NULL, lieutex = NULL) { #' #' @param clay vector of clay percentages #' @param sand vector of sand percentages +#' @param sandvf vector of very fine sand percentages #' #' @param fragvoltot vector of total rock fragment percentages #' #' @return - `texture_to_taxpartsize`: a character vector containing `"taxpartsize"` classes #' +#' @seealso [hz_to_taxpartsize()], [lookup_taxpartsize()] +#' #' @rdname texture #' #' @export #' -texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragvoltot = NULL) { +texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, sandvf = NULL, fragvoltot = NULL) { # check lengths idx <- length(texcl) == length(clay) & length(clay) == length(sand) & length(sand) == length(fragvoltot) @@ -432,9 +443,12 @@ texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragv # standarize inputs + if (is.null(sandvf)) sandvf <- NA + df <- data.frame(texcl = tolower(texcl), clay = as.integer(round(clay)), sand = as.integer(round(sand)), + sandvf = as.integer(round(sandvf)), fragvoltot = as.integer(round(fragvoltot)), fpsc = as.character(NA), stringsAsFactors = FALSE @@ -445,7 +459,7 @@ texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragv # check texcl lookup - idx <- any(! df$texcl %in% SoilTextureLevels(which = 'codes')) + idx <- any(! df$texcl[!is.na(df$texcl)] %in% SoilTextureLevels(which = 'codes')) if (idx) { warning("not all the texcl supplied match the lookup table") } @@ -453,9 +467,14 @@ texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragv # check percentages idx <- df$silt > 100 | df$silt < 0 | df$clay > 100 | df$clay < 0 | df$sand > 100 | df$sand < 0 | df$fragvoltot > 100 | df$fragvoltot < 0 - if (any(idx)) { + if (any(idx, na.rm = TRUE)) { warning("some records are > 100% or < 0%, or the calcuated silt fraction is > 100% or < 0%") } + + + if (any(sandvf > sand & all(!is.na(sandvf)))) { + warning("the sandvf values should not be greater than the sand values") + } # check ssc_to_texcl() vs texcl @@ -465,9 +484,18 @@ texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragv texcl_calc = ifelse(texcl_calc == "s" & grepl("^cos$|^fs$|^vfs$", texcl), texcl, texcl_calc) texcl_calc = ifelse(texcl_calc == "ls" & grepl("^lcos$|^lfs$|^lvfs$", texcl), texcl, texcl_calc) texcl_calc = ifelse(texcl_calc == "sl" & grepl("^cosl$|^fsl$|^vfsl$", texcl), texcl, texcl_calc) + + sandvf = ifelse(is.na(sandvf) & texcl %in% c("vfs", "lvfs"), 50, sandvf) + sandvf = ifelse(is.na(sandvf) & texcl %in% c("vfsl"), 40, sandvf) + sandvf = ifelse(is.na(sandvf) & texcl %in% c("fsl"), 15, sandvf) + sandvf = ifelse(is.na(sandvf) & texcl %in% c("sl", "l", "scl"), 10, sandvf) + sandvf = ifelse(is.na(sandvf) & texcl %in% c("fsl"), 7, sandvf) + + sand = ifelse(!is.na(sandvf), sand - sandvf, sand) + silt = ifelse(!is.na(sandvf), silt + sandvf, silt) }) - idx <- any(df$texcl != df$texcl_calc) + idx <- any(df$texcl != df$texcl_calc, na.rm = TRUE) if (idx) { warning("some of the texcl records don't match the calculated texcl via ssc_to_texcl()") } @@ -478,9 +506,9 @@ texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragv idx <- df$fragvoltot >= 35 if (any(idx)) { df[idx,] <- within(df[idx,], { - fpsc[texcl %in% sandytextures] = "sandy-skeletal" - fpsc[clay < 35] = "loamy-skeletal" fpsc[clay >= 35] = "clayey-skeletal" + fpsc[clay < 35] = "loamy-skeletal" + fpsc[texcl %in% sandytextures] = "sandy-skeletal" }) } @@ -507,6 +535,7 @@ texture_to_taxpartsize <- function(texcl = NULL, clay = NULL, sand = NULL, fragv } + #' Parse texmod from texture #' #' @param texmod vector of textural modifiers that conform to the USDA code @@ -1025,3 +1054,81 @@ fragvol_to_texmod <- function( return(df) } + +#' @title Ranking Systems for USDA Taxonomic Particle-Size and Substitute Classes of Mineral Soils +#' +#' @description Generate a lookup table of USDA Particle-Size and Substitute Classes names, ranked according to approximate particle size +#' +#' @references \href{https://nrcspad.sc.egov.usda.gov/DistributionCenter/product.aspx?ProductID=991}{Field Book for Describing and Sampling Soils, version 3.0} +#' +#' @return A data.frame with a rank column, taxonomic family particle size class, and a flag for contrasting. +#' +#' @author Stephen Roecker +#' +#' @seealso [hz_to_taxpartsize()], [texture_to_taxpartsize()], [SoilTextureLevels()] +#' +#' @export +#' @examples +#' +#' # class codes +#' lu <- lookup_taxpartsize() +#' +#' idx <- lu$contrasting == FALSE +#' +#' lu$taxpartsize[idx] +#' +#' lu$rank[as.integer(lu$taxpartsize)[idx]] +#' + +lookup_taxpartsize <- function() { + fe <- c("diatomaceous", "very-fine", "clayey", "fine", "hydrous", "fine-silty", + "fine-gypseous", "fine-loamy", "medial", "loamy", "coarse-loamy", + "coarse-silty", "coarse-gypseous", "ashy", "sandy", "hydrous-pumiceous", + "medial-pumiceous", "ashy-pumiceous", "clayey-skeletal", "hydrous-skeletal", + "medial-skeletal", "loamy-skeletal", "gypseous-skeletal", "ashy-skeletal", + "sandy-skeletal", "pumiceous", "cindery", "fragmental") + + rank <- c(84, 74, 60.02, 46.04, 44.04, 26, 25.8, 25.6, 24, 17.24, 8.88, + 8.5, 7.5, 6.5, 4.67, -55.96, -76, -93.5, -43.33, -55.96, -76, + -83.23, -83.35, -93.5, -95.33, -95.83, -96.33, -98.94) + names(rank) <- fe + + # cf <- c("fragmental", "sandy-skeletal", "loamy-skeletal", "clay-skeletal") + + test <- strsplit(.pscs_sc, " over | or ") + names(test) <- .pscs_sc + + idx <- lapply(test, function(x) { + idx <- unlist(sapply(x, function(y) rank[which(fe == y)])) + + # select the 3rd value when "or" results in 3 values + if (length(idx) > 2) idx <- c(idx[1], idx[3]) + + dif <- diff(idx) + idx <- idx[1] + sqrt(abs(dif)) * sign(dif) + # l <- dplyr::lag(idx) + # l <- idx[c(NA, 1:(length(idx) - 1))] + # idx <- ifelse(idx < l & !is.na(l), idx * -1, idx * 1) + # n <- length(idx) + # idx <- sum(idx * c(1, 0.1, 0.01, 0.001)[1:n]) + + + return(idx) + }) + idx <- round(unlist(idx), 1) + + # fe <- data.frame(rn = 1:length(fe), fe = fe) + fe_df <- data.frame(rank = unname(rank), taxpartsize = fe) + sc_df <- data.frame(rank = unname(idx), taxpartsize = .pscs_sc) + lu <- rbind(fe_df, sc_df) + lu <- lu[order(-lu$rank), ] + # lu$rn <- 1:nrow(lu) + lu$contrasting <- grepl(" over ", lu$taxpartsize) + lu$taxpartsize <- factor(lu$taxpartsize, levels = lu$taxpartsize, ordered = TRUE) + row.names(lu) <- NULL + + return(lu) +} + + +.pscs_sc <- tolower(c("Ashy over clayey", "Ashy over clayey-skeletal", "Ashy over loamy", "Ashy over loamy-skeletal", "Ashy over medial", "Ashy over medial-skeletal", "Ashy over pumiceous or cindery", "Ashy over sandy or sandy-skeletal", "Ashy-skeletal over clayey", "Ashy-skeletal over fragmental or cindery", "Ashy-skeletal over loamy-skeletal", "Ashy-skeletal over sandy or sandy-skeletal", "Cindery over loamy", "Cindery over medial", "Cindery over medial-skeletal", "Clayey over coarse-gypseous", "Clayey over fine-gypseous", "Clayey over fragmental", "Clayey over gypseous-skeletal", "Clayey over loamy", "Clayey over loamy-skeletal", "Clayey over sandy or sandy-skeletal", "Clayey-skeletal over sandy or sandy-skeletal", "Coarse-loamy over clayey", "Coarse-loamy over fragmental", "Coarse-loamy over sandy or sandy-skeletal", "Coarse-silty over clayey", "Coarse-silty over sandy or sandy-skeletal", "Fine-loamy over clayey", "Fine-loamy over fragmental", "Fine-loamy over sandy or sandy-skeletal", "Fine-silty over clayey", "Fine-silty over fragmental", "Fine-silty over sandy or sandy-skeletal", "Hydrous over clayey", "Hydrous over clayey-skeletal", "Hydrous over fragmental", "Hydrous over loamy", "Hydrous over loamy-skeletal", "Hydrous over sandy or sandy-skeletal", "Loamy over ashy or ashy-pumiceous", "Loamy over coarse-gypseous", "Loamy over fine-gypseous", "Loamy over pumiceous or cindery", "Loamy over sandy or sandy-skeletal", "Loamy-skeletal over cindery", "Loamy-skeletal over clayey", "Loamy-skeletal over fragmental", "Loamy-skeletal over gypseous-skeletal", "Loamy-skeletal over sandy or sandy-skeletal", "Medial over ashy", "Medial over ashy-pumiceous or ashy-skeletal", "Medial over clayey", "Medial over clayey-skeletal", "Medial over fragmental", "Medial over hydrous", "Medial over loamy", "Medial over loamy-skeletal", "Medial over pumiceous or cindery", "Medial over sandy or sandy-skeletal", "Medial-skeletal over fragmental or cindery", "Medial-skeletal over loamy-skeletal", "Medial-skeletal over sandy or sandy-skeletal", "Pumiceous or ashy-pumiceous over loamy", "Pumiceous or ashy-pumiceous over loamy-skeletal", "Pumiceous or ashy-pumiceous over medial", "Pumiceous or ashy-pumiceous over medial-skeletal", "Pumiceous or ashy-pumiceous over sandy or sandy-skeletal", "Sandy over clayey", "Sandy over loamy", "Sandy-skeletal over loamy")) diff --git a/R/thicknessOf.R b/R/thicknessOf.R new file mode 100644 index 000000000..3c3640568 --- /dev/null +++ b/R/thicknessOf.R @@ -0,0 +1,117 @@ +#' Calculate Thickness of Horizons Matching Logical Criteria +#' +#' This function calculates the cumulative (`method="cumulative"`, default) or maximum difference between (`method="minmax"`) horizons within a profile that match a defined pattern (`pattern`) or, more generally, any set of horizon-level logical expressions encoded in a function (`FUN`). +#' +#' @param x A _SoilProfileCollection_ +#' @param pattern _character_. A pattern to match in `hzdesgn`; used with the default `FUN` definition for regular expression pattern matching on horizons. +#' @param hzdesgn _character_. A column containing horizon designations or other horizon-level character label used to identify matches; used with the default `FUN` definition. +#' @param method _character_. Either `"cumulative"` (default) or `"minmax"`. See details. +#' @param prefix _character_. Column prefix for calculated `thickvar` (and `depthvar` for `method="minmax"`) column results. Default: `""`. +#' @param thickvar _character_ Length `1`. Column name to use for calculated thickness column. Default: `"thickness"` +#' @param depthvars _character_. Length `2`. Column names to use for calculated minimum top depth and maximum bottom depth in `method="minmax"`. Default: `horizonDepths(x)` +#' @param FUN _function_. A function that returns a _logical_ vector equal in length to the number of horizons in `x`. See details. +#' @param na.rm _logical_. Omit `NA` values in summaries of thickness and in matching? Default: `FALSE` +#' @param ... Additional arguments passed to the matching function `FUN`. +#' +#' @return A _data.frame_-like object (corresponding to the `aqp_df_class()` of `x`) with one row per profile in `x`. First column is always the profile ID which is followed by `"thickness"`. In `method="minmax"` the upper and lower boundaries used to calculate `"thickness"` are also returned as `"tmin"` and `"tmax"` columns, respectively. +#' +#' @details +#' The two thickness methods currently available are: +#' - `method="cumulative"` (default): cumulative thickness of horizons where `FUN` returns true +#' - `method="minmax"`: maximum bottom depth minus minimum top depth of horizons where `FUN` returns true +#' +#' If a custom function (`FUN`) is used, it should accept arbitrary additional arguments via an ellipsis (`...`). +#' It is not necessary to do anything with arguments, but the result should match the number of horizons found in the input SoilProfileCollection `x`. +#' +#' @export +#' +#' @examples +#' data("jacobs2000") +#' +#' # cumulative thickness of horizon designations matching "Bt" +#' thicknessOf(jacobs2000, "Bt") +#' +#' # maximum bottom depth minus minimum top depth of horizon designations matching "Bt" +#' thicknessOf(jacobs2000, "Bt", prefix = "Bt_", method = "minmax") +#' +#' # cumulative thickness of horizon designations matching "A|B" +#' thicknessOf(jacobs2000, "A|B", prefix = "AorB_") +#' +#' # maximum bottom depth minus minimum top depth of horizon designations matching "A|B" +#' thicknessOf(jacobs2000, "A|B", method = "minmax", prefix = "AorB_") +#' # note that the latter includes the thickness of E horizons between the A and the B +#' +#' # when using a custom function (be sure to accept ... and consider the effect of NA values) +#' +#' # calculate cumulative thickness of horizons containing >18% clay +#' thicknessOf(jacobs2000, prefix = "claygt18_", +#' FUN = function(x, ...) !is.na(x[["clay"]]) & x[["clay"]] > 18) +#' +thicknessOf <- function(x, + pattern = NULL, + hzdesgn = hzdesgnname(x, required = TRUE), + method = "cumulative", + prefix = "", + thickvar = "thickness", + depthvars = horizonDepths(x), + FUN = function(x, pattern, hzdesgn, ...) grepl(pattern, x[[hzdesgn]]), + na.rm = FALSE, + ...) { + + .internalTHK <- NULL + .internalHZM <- NULL + + if (is.null(hzdesgn) || !hzdesgn %in% horizonNames(x)) { + stop("Horizon designation column (", hzdesgn, ") does not exist.") + } + + # check inputs + method <- match.arg(tolower(gsub("/", "", method)), c("cumulative", "minmax")) + stopifnot(length(thickvar) == 1) + stopifnot(length(depthvars) == 2) + + # extract SPC column names and horizon data + hzd <- horizonDepths(x) + idn <- idname(x) + h <- data.table::data.table(horizons(x)) + + # determine horizons matching criteria of interest + h$.internalHZM <- FUN(x, pattern = pattern, hzdesgn = hzdesgn, na.rm = na.rm, ...) + + # create a named list for data.table aggregation + lid <- list(h[[idn]]) + names(lid) <- idn + + if (method == "cumulative") { + + # sum thicknesses of all matching horizons + h$.internalTHK <- x[[hzd[2]]] - x[[hzd[1]]] + res <- h[, list(thickness = sum(.internalTHK[.internalHZM], na.rm = na.rm)), by = lid] + colnames(res)[2] <- thickvar + + } else if (method == "minmax") { + + # determine minimum top depth and maximum bottom depth of matching horizons + res <- h[, list(`min` = suppressWarnings(min(.SD[[1]][.internalHZM], na.rm = na.rm)), + `max` = suppressWarnings(max(.SD[[2]][.internalHZM], na.rm = na.rm))), + by = lid, .SDcols = c(hzd, ".internalHZM")] + + # calculate thickness as MAX(bottom) - MIN(top) + res$thickness <- res$`max` - res$`min` + + # if a profile has no matching horizons min/max results will be +/- infinity + # this means the profile has 0 thickness of matching horizons + res$thickness[!is.finite(res$thickness)] <- 0L + + # use user-defined labels + colnames(res)[2:3] <- depthvars + colnames(res)[4] <- thickvar + } else stop("unknown thickness method: ", shQuote(method), call. = FALSE) + + # add prefix + colnames(res)[2:ncol(res)] <- paste0(prefix, colnames(res)[2:ncol(res)]) + + # return as SPC data.frame class type + .as.data.frame.aqp(res, aqp_df_class(x)) +} + diff --git a/R/unroll.R b/R/unroll.R index ef6f3ebf3..6f65b03b9 100644 --- a/R/unroll.R +++ b/R/unroll.R @@ -21,7 +21,7 @@ #' defaults to FALSE #' @return a vector of "unrolled" property values #' @author Dylan E. Beaudette -#' @references http://casoilresource.lawr.ucdavis.edu/ +#' @references https://casoilresource.lawr.ucdavis.edu/ #' @keywords manip #' @export #' @examples diff --git a/R/zzz.R b/R/zzz.R index 22c5dc903..1f36d21e6 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,6 +1,4 @@ -# .onLoad <- function(lib, pkg) { -# packageStartupMessage("This is aqp ", utils::packageDescription("aqp", field="Version"), "\n", "see http://casoilresource.lawr.ucdavis.edu/drupal/taxonomy/term/56 for examples", appendLF = TRUE) -# } + .onAttach <- function(lib, pkg) { packageStartupMessage("This is aqp ", utils::packageDescription("aqp", field="Version"), appendLF = TRUE) diff --git a/README.Rmd b/README.Rmd index 26e2fa4e4..a8bcaaeed 100644 --- a/README.Rmd +++ b/README.Rmd @@ -17,10 +17,12 @@ knitr::opts_chunk$set( ) ``` -[![R build status](https://github.com/ncss-tech/aqp/workflows/R-CMD-check/badge.svg)](https://github.com/ncss-tech/aqp/actions) -[![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/aqp)](http://cran.r-project.org/web/packages/aqp) -[![Total_Downloads](http://cranlogs.r-pkg.org/badges/grand-total/aqp)](https://cran.r-project.org/package=aqp) -[![aqp Manual](https://img.shields.io/badge/docs-HTML-informational)](http://ncss-tech.github.io/aqp/) +[![CRAN version](https://www.r-pkg.org/badges/version/aqp)](https://CRAN.R-project.org/package=aqp) +[![CRAN status](https://badges.cranchecks.info/worst/aqp.svg)](https://cran.r-project.org/web/checks/check_results_aqp.html) +[![Development Version](https://ncss-tech.r-universe.dev/badges/aqp)](https://ncss-tech.r-universe.dev/) +[![Monthly CRAN Downloads](https://cranlogs.r-pkg.org/badges/aqp)](https://cran.r-project.org/package=aqp) +![CRAN/METACRAN](https://img.shields.io/cran/l/aqp) +[![aqp Manual](https://img.shields.io/badge/docs-HTML-informational)](https://ncss-tech.github.io/aqp/) # Algorithms for Quantitative Pedology (aqp) package for R @@ -28,7 +30,7 @@ knitr::opts_chunk$set( aqp hexsticker (Paxton, Montauk, Woodbridge, Ridgebury, Whitman, Catden soil series dendogram) -The Algorithms for Quantitative Pedology (AQP) project was started in 2009 to organize a loosely-related set of concepts and source code on the topic of soil profile visualization, aggregation, and classification into this package (aqp). Over the past 8 years, the project has grown into a suite of related R packages that enhance and simplify the quantitative analysis of soil profile data. Central to the AQP project is a new vocabulary of specialized functions and data structures that can accommodate the inherent complexity of soil profile information; freeing the scientist to focus on ideas rather than boilerplate data processing tasks . These functions and data structures have been extensively tested and documented, applied to projects involving hundreds of thousands of soil profiles, and deeply integrated into widely used tools such as SoilWeb . Components of the AQP project (aqp, soilDB, sharpshootR, soilReports packages) serve an important role in routine data analysis within the USDA-NRCS Soil Science Division. The AQP suite of R packages offer a convenient platform for bridging the gap between pedometric theory and practice. +The Algorithms for Quantitative Pedology (AQP) project was started in 2009 to organize a loosely-related set of concepts and source code on the topic of soil profile visualization, aggregation, and classification into this package (aqp). Over the past 8 years, the project has grown into a suite of related R packages that enhance and simplify the quantitative analysis of soil profile data. Central to the AQP project is a new vocabulary of specialized functions and data structures that can accommodate the inherent complexity of soil profile information; freeing the scientist to focus on ideas rather than boilerplate data processing tasks . These functions and data structures have been extensively tested and documented, applied to projects involving hundreds of thousands of soil profiles, and deeply integrated into widely used tools such as SoilWeb . Components of the AQP project (aqp, soilDB, sharpshootR, soilReports packages) serve an important role in routine data analysis within the USDA-NRCS Soil Science Division. The AQP suite of R packages offer a convenient platform for bridging the gap between pedometric theory and practice. ## Installation @@ -49,7 +51,7 @@ Install suggested packages: p <- c("colorspace", "ape", "soilDB", "latticeExtra", "tactile", "compositions", "sharpshootR", "markovchain", "xtable", "testthat", "Gmedian", "farver", "Hmisc", "tibble", "RColorBrewer", "scales", "digest", -"MASS", "mpspline2", "soiltexture", "knitr", "rmarkdown") +"MASS", "mpspline2", "soiltexture", "knitr", "rmarkdown", "mvtnorm") install.packages(p) ``` @@ -94,6 +96,11 @@ plotSPC( citation("aqp") ``` +## Related Papers and Book Chapters + * Beaudette D.E., P. Roudier, and J. Skovlin. 2016. Probabilistic representation of genetic soil horizons. In Book Digital soil morphometrics. Springer. + * Maynard, J.J., S.W. Salley, D.E. Beaudette, and J.E. Herrick. 2020. Numerical soil classification supports soil identification by citizen scientists using limited, simple soil observations. Soil Science Society of America Journal 84:1675-1692. + * Beaudette, D. E., J. Skovlin, A. G. Brown, P. Roudier, and S. M. Roecker. "Algorithms for Quantitative Pedology." In Geopedology, edited by Joseph Alfred Zinck, Graciela Metternicht, Héctor Francisco del Valle, and Marcos Angelini, 201–22. Cham: Springer International Publishing, 2023. https://doi.org/10.1007/978-3-031-20667-2_11. + ## Related Packages * [soilDB](https://github.com/ncss-tech/soilDB) * [sharpshootR](https://github.com/ncss-tech/sharpshootR) @@ -102,7 +109,7 @@ citation("aqp") * [Introduction to SoilProfileCollection Objects](https://ncss-tech.github.io/aqp/articles/Introduction-to-SoilProfileCollection-Objects.html) * [Numerical Classification of Soil Profiles](https://ncss-tech.github.io/aqp/articles/NCSP.html) * [Overlapping Annotation](https://ncss-tech.github.io/aqp/articles/label-placement.html) - * [What is new in aqp 2.0?](https://ncss-tech.github.io/aqp/articles/new-in-aqp-2.html) + * [What is new in aqp 2.x?](https://ncss-tech.github.io/aqp/articles/new-in-aqp-2.html) ## Tutorials * [Soil Profile Sketches](https://ncss-tech.github.io/AQP/aqp/sketches.html) diff --git a/README.md b/README.md index 8a2e2b371..718ebf7d0 100644 --- a/README.md +++ b/README.md @@ -1,12 +1,16 @@ -[![R build -status](https://github.com/ncss-tech/aqp/workflows/R-CMD-check/badge.svg)](https://github.com/ncss-tech/aqp/actions) -[![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/aqp)](http://cran.r-project.org/web/packages/aqp) -[![Total_Downloads](http://cranlogs.r-pkg.org/badges/grand-total/aqp)](https://cran.r-project.org/package=aqp) -[![aqp -Manual](https://img.shields.io/badge/docs-HTML-informational)](http://ncss-tech.github.io/aqp/) +[![CRAN +version](https://www.r-pkg.org/badges/version/aqp)](https://CRAN.R-project.org/package=aqp) +[![CRAN +status](https://badges.cranchecks.info/worst/aqp.svg)](https://cran.r-project.org/web/checks/check_results_aqp.html) +[![Development +Version](https://ncss-tech.r-universe.dev/badges/aqp)](https://ncss-tech.r-universe.dev/) +[![Monthly CRAN +Downloads](https://cranlogs.r-pkg.org/badges/aqp)](https://cran.r-project.org/package=aqp) +![CRAN/METACRAN](https://img.shields.io/cran/l/aqp) [![aqp +Manual](https://img.shields.io/badge/docs-HTML-informational)](https://ncss-tech.github.io/aqp/) # Algorithms for Quantitative Pedology (aqp) package for R @@ -28,7 +32,7 @@ processing tasks . These functions and data structures have been extensively tested and documented, applied to projects involving hundreds of thousands of soil profiles, and deeply integrated into widely used tools such as SoilWeb -. Components of +. Components of the AQP project (aqp, soilDB, sharpshootR, soilReports packages) serve an important role in routine data analysis within the USDA-NRCS Soil Science Division. The AQP suite of R packages offer a convenient @@ -55,7 +59,7 @@ Install suggested packages: p <- c("colorspace", "ape", "soilDB", "latticeExtra", "tactile", "compositions", "sharpshootR", "markovchain", "xtable", "testthat", "Gmedian", "farver", "Hmisc", "tibble", "RColorBrewer", "scales", "digest", -"MASS", "mpspline2", "soiltexture", "knitr", "rmarkdown") +"MASS", "mpspline2", "soiltexture", "knitr", "rmarkdown", "mvtnorm") install.packages(p) ``` @@ -117,6 +121,21 @@ citation("aqp") #> 'options(citation.bibtex.max=999)'. ``` +## Related Papers and Book Chapters + +- Beaudette D.E., P. Roudier, and J. Skovlin. 2016. Probabilistic + representation of genetic soil horizons. In Book Digital soil + morphometrics. Springer. +- Maynard, J.J., S.W. Salley, D.E. Beaudette, and J.E. Herrick. 2020. + Numerical soil classification supports soil identification by citizen + scientists using limited, simple soil observations. Soil Science + Society of America Journal 84:1675-1692. +- Beaudette, D. E., J. Skovlin, A. G. Brown, P. Roudier, and S. M. + Roecker. “Algorithms for Quantitative Pedology.” In Geopedology, + edited by Joseph Alfred Zinck, Graciela Metternicht, Héctor Francisco + del Valle, and Marcos Angelini, 201–22. Cham: Springer International + Publishing, 2023. . + ## Related Packages - [soilDB](https://github.com/ncss-tech/soilDB) @@ -131,7 +150,7 @@ citation("aqp") - [Overlapping Annotation](https://ncss-tech.github.io/aqp/articles/label-placement.html) - [What is new in aqp - 2.0?](https://ncss-tech.github.io/aqp/articles/new-in-aqp-2.html) + 2.x?](https://ncss-tech.github.io/aqp/articles/new-in-aqp-2.html) ## Tutorials diff --git a/data/equivalent_munsell.rda b/data/equivalent_munsell.rda index e8cbd69c0..e2abf73f4 100644 Binary files a/data/equivalent_munsell.rda and b/data/equivalent_munsell.rda differ diff --git a/data/munsell.rda b/data/munsell.rda index de8e7a901..31e9114c7 100644 Binary files a/data/munsell.rda and b/data/munsell.rda differ diff --git a/data/munsell.spectra.rda b/data/munsell.spectra.rda index 173a39d6f..b90ac023d 100644 Binary files a/data/munsell.spectra.rda and b/data/munsell.spectra.rda differ diff --git a/data/munsell.spectra.wide.rda b/data/munsell.spectra.wide.rda index 463a0ec3a..a1899ee9a 100644 Binary files a/data/munsell.spectra.wide.rda and b/data/munsell.spectra.wide.rda differ diff --git a/man/allocate.Rd b/man/allocate.Rd index 76b2f92e7..e391ae78d 100644 --- a/man/allocate.Rd +++ b/man/allocate.Rd @@ -163,9 +163,9 @@ aggregate(featdept ~ id, data = df, summary) } \references{ -Abrol, I., Yadav, J. & Massoud, F. 1988. \href{https://www.fao.org/3/x5871e/x5871e00.htm}{Salt-affected soils and their management}. No. Bulletin 39. Rome, FAO Soils. +Abrol, I., Yadav, J. & Massoud, F. 1988. \href{https://www.fao.org/4/x5871e/x5871e00.htm}{Salt-affected soils and their management}. No. Bulletin 39. Rome, FAO Soils. -FAO. 2006. \href{https://www.fao.org/publications/card/en/c/903943c7-f56a-521a-8d32-459e7e0cdae9/}{Guidelines for soil description}. Rome, Food and Agriculture Organization of the United Nations. +FAO. 2006. \href{https://www.fao.org/4/a0541e/a0541e.pdf}{Guidelines for soil description}. Rome, Food and Agriculture Organization of the United Nations. FAO. 2020. DEFINITION | What is a black soil? (online). (Cited 28 December 2020). http://www.fao.org/global-soil-partnership/intergovernmental-technical-panel-soils/gsoc17-implementation/internationalnetworkblacksoils/more-on-black-soils/definition-what-is-a-black-soil/es/ @@ -175,3 +175,6 @@ Richards, L.A. 1954. \href{https://www.ars.usda.gov/ARSUserFiles/20360500/hb60_p Soil Survey Staff, 2014. Keys to Soil Taxonomy, 12th ed. USDA-Natural Resources Conservation Service, Washington, D.C. } +\author{ +Stephen Roecker +} diff --git a/man/depthOf.Rd b/man/depthOf.Rd index 1f72741f3..b8c9d25a6 100644 --- a/man/depthOf.Rd +++ b/man/depthOf.Rd @@ -11,7 +11,7 @@ depthOf( 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, @@ -22,7 +22,7 @@ maxDepthOf( p, pattern, top = TRUE, - hzdesgn = guessHzDesgnName(p), + hzdesgn = hzdesgnname(p, required = TRUE), no.contact.depth = NULL, no.contact.assigned = NA, na.rm = TRUE, @@ -33,7 +33,7 @@ minDepthOf( 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/man/diagnostic_hz-set.Rd b/man/diagnostic_hz-set.Rd deleted file mode 100644 index 91d0508bf..000000000 --- a/man/diagnostic_hz-set.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SoilProfileCollection-setters.R -\docType{methods} -\name{diagnostic_hz<-} -\alias{diagnostic_hz<-} -\alias{diagnostic_hz<-,SoilProfileCollection-method} -\title{Add Data to Diagnostic Features Slot} -\usage{ -\S4method{diagnostic_hz}{SoilProfileCollection}(object) <- value -} -\arguments{ -\item{object}{A SoilProfileCollection} - -\item{value}{An object inheriting \code{data.frame}} -} -\description{ -Diagnostic feature data in an object inheriting from \code{data.frame} can easily be added via merge (LEFT JOIN). There must be one or more same-named columns containing profile ID on the left and right hand side to facilitate the join: \code{diagnostic_hz(spc) <- newdata} -} -\examples{ - -# load test data -data(sp2) - -# promote to SPC -depths(sp2) <- id ~ top + bottom - -# assign two profiles a zone related to the mollic epipedon -newdata <- data.frame(id = c("hon-1","hon-17"), - featkind = "fixed-depth surface sample", - featdept = 0, - featdepb = 18) - -# do left join -diagnostic_hz(sp2) <- newdata - -# inspect site table: newvalue TRUE only for horizons -# with top depth equal to zero -diagnostic_hz(sp2) - -} diff --git a/man/diagnostic_hz.Rd b/man/diagnostic_hz.Rd index 074c70033..45a6089e8 100644 --- a/man/diagnostic_hz.Rd +++ b/man/diagnostic_hz.Rd @@ -1,16 +1,52 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Class-SoilProfileCollection.R +% Please edit documentation in R/Class-SoilProfileCollection.R, +% R/SoilProfileCollection-setters.R \docType{methods} \name{diagnostic_hz,SoilProfileCollection-method} \alias{diagnostic_hz,SoilProfileCollection-method} \alias{diagnostic_hz} -\title{Retrieve diagnostic data from SoilProfileCollection} +\alias{diagnostic_hz<-} +\alias{diagnostic_hz<-,SoilProfileCollection-method} +\title{Get or Set Diagnostic Horizon data in a SoilProfileCollection} \usage{ \S4method{diagnostic_hz}{SoilProfileCollection}(object) + +\S4method{diagnostic_hz}{SoilProfileCollection}(object) <- value } \arguments{ -\item{object}{a SoilProfileCollection} +\item{object}{A SoilProfileCollection} + +\item{value}{An object inheriting from \code{data.frame}} } \description{ -Get diagnostic feature data from SoilProfileCollection. Result is returned in the same \code{data.frame} class used to initially construct the SoilProfileCollection. +Diagnostic horizons describe features of the soil relevant to taxonomic classification. A single profile may have multiple diagnostic features or horizons, each of which may be comprised of multiple horizons. +\itemize{ +\item \code{diagnostic_hz()} (get method): Get diagnostic feature data from a SoilProfileCollection. +} + +\itemize{ +\item \verb{diagnostic_hz<-} (set method): Set diagnostic feature data for a SoilProfileCollection. The profile ID column from \code{object} (\code{idname(object)}) must be present in the replacement \code{value} object. +} +} +\examples{ + +# load test data +data(sp2) + +# promote to SPC +depths(sp2) <- id ~ top + bottom + +# assign two profiles a zone related to the mollic epipedon +newdata <- data.frame(id = c("hon-1","hon-17"), + featkind = "fixed-depth surface sample", + featdept = 0, + featdepb = 18) + +# do left join +diagnostic_hz(sp2) <- newdata + +# inspect site table: newvalue TRUE only for horizons +# with top depth equal to zero +diagnostic_hz(sp2) + } diff --git a/man/equivalentMunsellChips.Rd b/man/equivalentMunsellChips.Rd index 905b03dda..2762c08e4 100644 --- a/man/equivalentMunsellChips.Rd +++ b/man/equivalentMunsellChips.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/similarMunsellChips.R +% Please edit documentation in R/equivalentMunsellChips.R \name{equivalentMunsellChips} \alias{equivalentMunsellChips} \title{Identify "equivalent" (whole number value/chroma) Munsell chips} @@ -21,7 +21,7 @@ Uses a pre-calculated lookup list (\code{\link{equivalent_munsell}}) based on pa The intention is to identify Munsell chips that may be "functionally equivalent" to some other given whole value/chroma chip elsewhere in the Munsell color space -- as discretized in the \code{aqp::munsell} data table. This basic assumption needs to be validated against your end goal: probably by visual inspection of some or all of the resulting sets. See \code{\link{colorContrast}} and \code{\link{colorContrastPlot}}. -"Equivalent" chips table are based (fairly arbitrarily) on the 0.001 probability level of dE00 (default Type 7 \code{quantile}) within the upper triangle of the 8467x8467 contrast matrix. This corresponds to a \code{dE00} contrast threshold of approximately 2.15. +"Equivalent" chips table are based (fairly arbitrarily) on the 0.001 probability level of dE00 (default Type 7 \code{quantile}) within the upper triangle of the 8467x8467 contrast matrix. This corresponds to a \code{dE00} contrast threshold of approximately 2.16. } \examples{ diff --git a/man/estimatePSCS.Rd b/man/estimatePSCS.Rd index cdb3751ac..ba3dfe3c8 100644 --- a/man/estimatePSCS.Rd +++ b/man/estimatePSCS.Rd @@ -7,9 +7,9 @@ \usage{ estimatePSCS( 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), tax_order_field = "tax_order", lieutex = "lieutex", bottom.pattern = "Cr|R|Cd|m", @@ -74,12 +74,13 @@ data(sp1, package = 'aqp') 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 - +# set required metadata +hzdesgnname(sp1) <- 'name' +hztexclname(sp1) <- 'texture' +hzmetaname(sp1, 'clay') <- 'prop' +x <- estimatePSCS(sp1) +x } \references{ Soil Survey Staff. 2014. Keys to Soil Taxonomy, 12th ed. diff --git a/man/evalGenHZ.Rd b/man/evalGenHZ.Rd index 4132fd9af..3fd131f20 100644 --- a/man/evalGenHZ.Rd +++ b/man/evalGenHZ.Rd @@ -17,47 +17,44 @@ evalGenHZ( \arguments{ \item{obj}{a \code{SoilProfileCollection} object} -\item{genhz}{name of horizon-level attribute containing generalized horizon -labels} +\item{genhz}{name of horizon-level attribute containing generalized horizon labels} -\item{vars}{character vector of horizon-level attributes to include in the -evaluation} +\item{vars}{character vector of horizon-level attributes to include in the evaluation} -\item{non.matching.code}{code used to represent horizons not assigned a -generalized horizon label} +\item{non.matching.code}{code used to represent horizons not assigned a generalized horizon label} -\item{stand}{standardize variables before computing distance matrix (default -= TRUE), passed to \code{\link{daisy}}} +\item{stand}{standardize variables before computing distance matrix, passed to \code{\link[cluster:daisy]{cluster::daisy()}}} -\item{trace}{verbose output from passed to \code{\link{isoMDS}}, (default = -FALSE)} +\item{trace}{verbose output from passed to \code{\link[MASS:isoMDS]{MASS::isoMDS()}}} -\item{metric}{distance metric, passed to \code{\link{daisy}}} +\item{metric}{distance metric, passed to \code{\link[cluster:daisy]{cluster::daisy()}}} } \value{ -a list is returned containing: \describe{ \item{horizons}{c('mds.1', -'mds.2', 'sil.width', 'neighbor')} \item{stats}{mean and standard deviation -of \code{vars}, computed by generalized horizon label} \item{dist}{the -distance matrix as passed to \code{\link{isoMDS}}} } +a list is returned containing: +\itemize{ +\item horizons: \verb{c('mds.1', mds.2', 'sil.width', 'neighbor')} +\item stats: mean and standard deviation \code{vars}, computed by generalized horizon label +\item dist: the distance matrix as passed to \code{\link[MASS:isoMDS]{MASS::isoMDS()}} +} } \description{ Data-driven evaluation of generalized horizon labels using nMDS and silhouette width. } \details{ -Non-metric multidimensional scaling is performed via \code{\link{isoMDS}}. -The input distance matrix is generated by \code{\link{daisy}} using +Non-metric multidimensional scaling is performed via \code{\link[MASS:isoMDS]{MASS::isoMDS()}}. +The input distance matrix is generated by \code{\link[cluster:daisy]{cluster::daisy()}} using (complete cases of) horizon-level attributes from \code{obj} as named in \code{vars}. -Silhouette widths are computed via \code{\link{silhouette}}. The input -distance matrix is generated by \code{\link{daisy}} using (complete cases +Silhouette widths are computed via \code{\link[cluster:silhouette]{cluster::silhouette()}}. The input +distance matrix is generated by \code{\link[cluster:daisy]{cluster::daisy()}} using (complete cases of) horizon-level attributes from \code{obj} as named in \code{vars}. Note that observations with genhz labels specified in \code{non.matching.code} are removed filtered before calculation of the distance matrix. } \seealso{ -\code{\link{get.ml.hz}} +\code{\link[=get.ml.hz]{get.ml.hz()}} } \author{ D.E. Beaudette diff --git a/man/flagOverlappingHz.Rd b/man/flagOverlappingHz.Rd index 30a70ab62..639819645 100644 --- a/man/flagOverlappingHz.Rd +++ b/man/flagOverlappingHz.Rd @@ -15,6 +15,9 @@ logical vector with length (and order) matching the horizons of \code{x} \description{ Flag perfectly overlapping horizons within a SoilProfileCollection } +\details{ +Horizons with \code{NA} depths can be flagged as overlapping. Consider finding these horizons with \code{checkHzDepthLogic(byhz=TRUE)} and removing or fixing them. +} \examples{ # two overlapping horizons @@ -34,7 +37,10 @@ z$.overlapFlag <- flagOverlappingHz(z) plotSPC(z, color = '.overlapFlag', hz.depths = TRUE, depth.axis = FALSE, cex.names = 0.85) +} +\seealso{ +\code{\link[=checkHzDepthLogic]{checkHzDepthLogic()}} \code{\link[=fillHzGaps]{fillHzGaps()}} } \author{ -D.E. Beaudette +D.E. Beaudette, A.G. Brown } diff --git a/man/getArgillicBounds.Rd b/man/getArgillicBounds.Rd index b3e740225..44c0fa43d 100644 --- a/man/getArgillicBounds.Rd +++ b/man/getArgillicBounds.Rd @@ -6,9 +6,9 @@ \usage{ getArgillicBounds( 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]*$", @@ -65,10 +65,13 @@ data(sp1, package = 'aqp') 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 } \author{ diff --git a/man/getCambicBounds.Rd b/man/getCambicBounds.Rd index b1358d29a..70c9ec81d 100644 --- a/man/getCambicBounds.Rd +++ b/man/getCambicBounds.Rd @@ -6,9 +6,9 @@ \usage{ getCambicBounds( 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", @@ -60,8 +60,11 @@ spc <- data.frame(id=1, taxsubgrp = "Lithic Haploxerepts", # 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) diff --git a/man/getClosestMunsellChip.Rd b/man/getClosestMunsellChip.Rd index bb2db3250..f04d43f8a 100644 --- a/man/getClosestMunsellChip.Rd +++ b/man/getClosestMunsellChip.Rd @@ -7,7 +7,7 @@ getClosestMunsellChip(munsellColor, convertColors = TRUE, ...) } \arguments{ -\item{munsellColor}{character vector of strings containing Munsell notation of color, e.g. '10YR 4/3'} +\item{munsellColor}{character vector of strings containing Munsell notation of color, e.g. '10YR 4/3', not NA-safe} \item{convertColors}{logical, should parsed Munsell colors be converted into sRGB values} diff --git a/man/getSurfaceHorizonDepth.Rd b/man/getSurfaceHorizonDepth.Rd index 6424c69b2..ba7af8aa6 100644 --- a/man/getSurfaceHorizonDepth.Rd +++ b/man/getSurfaceHorizonDepth.Rd @@ -9,20 +9,20 @@ getSurfaceHorizonDepth( p, pattern, - hzdesgn = guessHzDesgnName(p), + hzdesgn = hzdesgnname(p, required = TRUE), simplify = TRUE ) getMineralSoilSurfaceDepth( p, - hzdesgn = guessHzDesgnName(p), + hzdesgn = hzdesgnname(p, required = TRUE), pattern = "O", simplify = TRUE ) getPlowLayerDepth( p, - hzdesgn = guessHzDesgnName(p), + hzdesgn = hzdesgnname(p, required = TRUE), pattern = "^Ap[^b]*", simplify = TRUE ) @@ -32,7 +32,7 @@ getPlowLayerDepth( \item{pattern}{a regular expression pattern to match for all horizons to be considered part of the "surface".} -\item{hzdesgn}{column name containing horizon designation. Default: \code{guessHzDesgnName(p, required = TRUE)}.} +\item{hzdesgn}{column name containing horizon designation. Default: \code{hzdesgnname(p, required = TRUE)}.} \item{simplify}{logical. Return single profile results as vector (default: \code{TRUE}) or \code{data.frame} (\code{FALSE})} } diff --git a/man/guessHzAttrName.Rd b/man/guessHzAttrName.Rd index 7d3247fa5..0733b6e6e 100644 --- a/man/guessHzAttrName.Rd +++ b/man/guessHzAttrName.Rd @@ -15,11 +15,11 @@ guessHzTexClName(x, required = FALSE) \arguments{ \item{x}{A SoilProfileCollection} -\item{attr}{A regular expression containing required formative element of attribute name.} +\item{attr}{\emph{character}. A regular expression containing required formative element of attribute name.} -\item{optional}{A character vector of regular expression(s) containing optional formative elements of attribute name.} +\item{optional}{\emph{character}. Vector of regular expression(s) containing optional formative elements of attribute name.} -\item{verbose}{A boolean value for whether to produce message output about guesses.} +\item{verbose}{\emph{logical}. Produce message output about guesses? Default: \code{TRUE}} \item{required}{logical Default: \code{FALSE}. Is this attribute required? If it is, set to \code{TRUE} to trigger error on invalid value.} } @@ -31,9 +31,9 @@ Character containing horizon attribute column name. Result is the first match in e.g. \code{guessHzAttrName(x, attr="clay", optional=c("total", "_r"))} matches (\code{claytotal_r == totalclay_r}) over (\code{clay_r == claytotal == totalclay}) over \code{clay}. -\code{guessHzDesgnName()}: This follows the historic convention used by \code{aqp::plotSPC()} looking for "hzname" or other column names containing the regular expression "name". If the pattern "name" is not found, the pattern "desgn" is searched as a fallback, as "hzdesgn" or "hz_desgn" are other common column naming schemes for horizon designation name. +\code{guessHzDesgnName()}: \strong{DEPRECATED} This follows the historic convention used by \code{aqp::plotSPC()} looking for "hzname" or other column names containing the regular expression "name". If the pattern "name" is not found, the pattern "desgn" is searched as a fallback, as "hzdesgn" or "hz_desgn" are other common column naming schemes for horizon designation name. -\code{guessHzTexClName()}: This function is used to provide a texture class attribute column name to functions. It will use regular expressions to match "texcl" which is typically the texture of the fine earth fraction, without modifiers or in-lieu textures. Alternately, it will match "texture" for cases where "texcl" is absent (e.g. in NASIS Component Horizon). +\code{guessHzTexClName()}: \strong{DEPRECATED} This function is used to provide a texture class attribute column name to functions. It will use regular expressions to match "texcl" which is typically the texture of the fine earth fraction, without modifiers or in-lieu textures. Alternately, it will match "texture" for cases where "texcl" is absent (e.g. in NASIS Component Horizon). } \examples{ @@ -61,26 +61,6 @@ depths(c) <- id ~ top + bottom guessHzAttrName(c, attr="clay", optional=c("total", "_r")) - -a <- data.frame(id = 1, top = c(0,10), bottom=c(10,40), horizonname=c("A","Bw")) -depths(a) <- id ~ top + bottom - -# store guess in metadata -hzdesgnname(a) <- guessHzDesgnName(a) - -# inspect result -hzdesgnname(a) - - -a <- data.frame(id = 1, top = c(0,10), bottom=c(10,40), texture=c("A","Bw")) -depths(a) <- id ~ top + bottom - -# store guess in metadata -hztexclname(a) <- guessHzTexClName(a) - -# inspect result -hztexclname(a) - } \author{ Andrew G. Brown diff --git a/man/harden.melanization.Rd b/man/harden.melanization.Rd index a129727dc..0c8066b70 100644 --- a/man/harden.melanization.Rd +++ b/man/harden.melanization.Rd @@ -50,7 +50,7 @@ jacobs2000$c_horizon_color <- profileApply(jacobs2000, function(p) { jacobs2000$melan <- profileApply(jacobs2000, function(p) { # sum the melanization index over the 0-100cm interval - p0_100 <- segment(p, 0:100) + p0_100 <- hz_segment(p, 0:100) ccol <- parseMunsell(p$c_horizon_color, convertColors = FALSE) diff --git a/man/harden.rubification.Rd b/man/harden.rubification.Rd index 79a7fb792..d0c52ff25 100644 --- a/man/harden.rubification.Rd +++ b/man/harden.rubification.Rd @@ -56,7 +56,7 @@ jacobs2000$c_horizon_color <- profileApply(jacobs2000, function(p) { jacobs2000$rubif <- profileApply(jacobs2000, function(p) { # sum the melanization index over the 0-100cm interval - p0_100 <- segment(p, 0:100) + p0_100 <- hz_segment(p, 0:100) ccol <- parseMunsell(p$c_horizon_color, convertColors = FALSE) diff --git a/man/dissolve_hz.Rd b/man/hz_dissolve.Rd similarity index 61% rename from man/dissolve_hz.Rd rename to man/hz_dissolve.Rd index 44df6c0a7..742725828 100644 --- a/man/dissolve_hz.Rd +++ b/man/hz_dissolve.Rd @@ -1,15 +1,25 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/segment.R -\name{dissolve_hz} +\name{hz_dissolve} +\alias{hz_dissolve} \alias{dissolve_hz} \title{Dissolving horizon boundaries by grouping variables} \usage{ +hz_dissolve( + object, + by, + idcol = "id", + depthcols = c("top", "bottom"), + collapse = FALSE, + order = FALSE +) + dissolve_hz( object, by, - id = "peiid", - hztop = "hzdept", - hzbot = "hzdepb", + id = "idcol", + hztop = "top", + hzbot = "bottom", collapse = FALSE, order = FALSE ) @@ -19,19 +29,22 @@ dissolve_hz( \item{by}{character: column names, to be used as grouping variables, within the object.} -\item{id}{character: column name of the pedon ID within the object.} - -\item{hztop}{character: column name of the horizon top depth within the object.} +\item{idcol}{character: column name of the pedon ID within the object.} -\item{hzbot}{character: column name of the horizon bottom depth in the object.} +\item{depthcols}{a character vector of length 2 specifying the names of the horizon depths (e.g. \code{c("top", "bottom")}).} \item{collapse}{logical: indicating whether to not combine grouping variables before dissolving.} -\item{order}{logical: indicating whether or not to order the object by the id, hztop, and hzbot columns. -#'} +\item{order}{logical: indicating whether or not to order the object by the id, hztop, and hzbot columns.} + +\item{id}{deprecated and replaced with idcol.} + +\item{hztop}{deprecated and replaced by depthcols.} + +\item{hzbot}{deprecated and replaced by depthcols.} } \value{ -A \code{data.frame} with the original id, by grouping variables, and non-consecutive horizon depths. +A \code{data.frame} with the original idcol, by grouping variables, and non-consecutive horizon depths. } \description{ This function dissolves or combines horizons that have a common set of grouping variables. It only combines those horizon records that are sequential (e.g. share a horizon boundary). Thus, it can be used to identify discontinuities in the grouping variables along a profile and their unique depths. It is particularly useful for determining the depth to the top or bottom of horizons with a specific category, and should be simpler than previous methods that require aggregating over profiles. @@ -49,7 +62,7 @@ spc$dep_5 <- spc$depletion_pct >=5 spc$genhz <- generalize.hz(spc$name, c("A", "E", "B", "C"), c("A", "E", "B", "C")) h <- horizons(spc) -test <- dissolve_hz(h, by = c("genhz", "dep_5"), id = "id", hztop = "top", hzbot = "bottom") +test <- hz_dissolve(h, by = c("genhz", "dep_5"), idcol = "id", depthcols = c("top", "bottom")) vars <- c("id", "top", "bottom", "genhz", "dep_5") h[h$id == "92-1", vars] @@ -58,9 +71,9 @@ test[test$id == "92-1", ] # example 2 df <- data.frame( - peiid = 1, - hzdept = c(0, 5, 10, 15, 25, 50), - hzdepb = c(5, 10, 15, 25, 50, 100), + id = 1, + top = c(0, 5, 10, 15, 25, 50), + bottom = c(5, 10, 15, 25, 50, 100), hzname = c("A1", "A2", "E/A", "2Bt1", "2Bt2", "2C"), genhz = c("A", "A", "E", "2Bt", "2Bt", "2C"), texcl = c("sil", "sil", "sil", "sl", "sl", "s") @@ -68,15 +81,15 @@ df <- data.frame( df -dissolve_hz(df, c("genhz", "texcl")) -dissolve_hz(df, c("genhz", "texcl"), collapse = TRUE) +hz_dissolve(df, c("genhz", "texcl")) +hz_dissolve(df, c("genhz", "texcl"), collapse = TRUE) -test <- dissolve_hz(df, "genhz") +test <- hz_dissolve(df, "genhz") subset(test, value == "2Bt") } \seealso{ -\code{\link{checkHzDepthLogic}} +\code{\link[=hz_lag]{hz_lag()}}, \code{\link[=hz_intersect]{hz_intersect()}}, \code{\link[=hz_segment]{hz_segment()}} , \code{\link[=checkHzDepthLogic]{checkHzDepthLogic()}} } \author{ Stephen Roecker diff --git a/man/hz_intersect.Rd b/man/hz_intersect.Rd new file mode 100644 index 000000000..6841ec1b7 --- /dev/null +++ b/man/hz_intersect.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/segment.R +\name{hz_intersect} +\alias{hz_intersect} +\title{Intersecting horizon boundaries by horizon depths} +\usage{ +hz_intersect(x, y, idcol = "id", depthcols = c("top", "bottom")) +} +\arguments{ +\item{x}{a \code{data.frame}} + +\item{y}{a \code{data.frame}} + +\item{idcol}{character: column name of the pedon ID within the object.} + +\item{depthcols}{a character vector of length 2 specifying the names of the horizon depths (e.g. \code{c("top", "bottom")}).} +} +\value{ +A \code{data.frame} with harmonized depth intervals (i.e. segment_id) and columns from both of the original \code{data.frame}. If both \code{data.frame} contain the same column names, they will both be returned (with the exception of the idcol and depthcols), and appended with either x or y to indicate which \code{data.frame} they originated from. +} +\description{ +This function intersects two horizon tables by harmonizing their depths and merging them where they overlap. This can be useful to rejoin the results of \code{hz_dissolve()} to it's original horizon table, and then perform an aggregation on the dissolved variables. +} +\details{ +. +} +\examples{ + +h <- data.frame( + id = 1, + top = c(0, 25, 44, 46, 50), + bottom = c(25, 44, 46, 50, 100), + by = c("Yes", "Yes", "No", "No", "Yes"), + clay = c(10, 12, 27, 35, 16) +) + +hz_dissolve(h, "by") + +hz_intersect(x = hz_dissolve(h, "by"), y = h) + +hi <- hz_intersect(x = h, y = hz_dissolve(h, "by")) +aggregate(clay ~ dissolve_id, data = hi, mean) + +} +\seealso{ +\code{\link[=hz_dissolve]{hz_dissolve()}}, \code{\link[=hz_lag]{hz_lag()}}, \code{\link[=hz_segment]{hz_segment()}} +} +\author{ +Stephen Roecker +} diff --git a/man/hz_lag.Rd b/man/hz_lag.Rd new file mode 100644 index 000000000..4acb253b6 --- /dev/null +++ b/man/hz_lag.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/segment.R +\name{hz_lag} +\alias{hz_lag} +\title{Find lagged horizon values} +\usage{ +hz_lag( + object, + lag = 1, + unit = "index", + idcol = "id", + depthcols = c("top", "bottom"), + order = FALSE +) +} +\arguments{ +\item{object}{a \code{data.frame}} + +\item{lag}{integer: number of horizons to lag} + +\item{unit}{character: lag units in index or depth.} + +\item{idcol}{character: column name of the pedon ID within the object.} + +\item{depthcols}{a character vector of length 2 specifying the names of the horizon depths (e.g. \code{c("top", "bottom")}).} + +\item{order}{logical: indicating whether or not to order the #'} +} +\value{ +A \code{data.frame} with lagged values. +} +\description{ +This function finds adjacent values to a horizon values at lagged distances. +} +\details{ +. +} +\examples{ + +h <- data.frame( + id = 1, + top = c(0, 25, 44, 46, 50), + bottom = c(25, 44, 46, 50, 100), + texcl = c("SL", "SL", "CL", "CL", "L"), + clay = c(10, 12, 27, 35, 16) +) + +hz_lag(h) + +hz_lag(h, -1) + +hz_lag(h, 10:15, unit = "depth") + +transform(cbind(h, lag = hz_lag(h)), + clay_dif = lag.clay_bot.1 - clay, + texcl_contrast = paste0(texcl, "-", lag.texcl_bot.1) +) + +} +\seealso{ +\code{\link[=hz_dissolve]{hz_dissolve()}}, \code{\link[=hz_intersect]{hz_intersect()}}, \code{\link[=hz_segment]{hz_segment()}} +} +\author{ +Stephen Roecker +} diff --git a/man/segment.Rd b/man/hz_segment.Rd similarity index 74% rename from man/segment.Rd rename to man/hz_segment.Rd index bfad07f73..db41673df 100644 --- a/man/segment.Rd +++ b/man/hz_segment.Rd @@ -1,10 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/segment.R -\name{segment} +\name{hz_segment} +\alias{hz_segment} \alias{segment} \title{Segmenting of Soil Horizon Data by Depth Interval} \usage{ -segment(object, intervals, trim = TRUE, hzdepcols = NULL) +hz_segment(object, intervals, trim = TRUE, depthcols = c("top", "bottom")) + +segment(object, intervals, trim = TRUE, hzdepcols = c("top", "bottom")) } \arguments{ \item{object}{either a \code{SoilProfileCollection} or \code{data.frame}} @@ -13,7 +16,9 @@ segment(object, intervals, trim = TRUE, hzdepcols = NULL) \item{trim}{logical, when \code{TRUE} horizons in \code{object} are truncated to the min/max specified in \code{intervals}. When \code{FALSE}, those horizons overlapping an interval are marked as such. Care should be taken when specifying more than one depth interval and \code{trim = FALSE}.} -\item{hzdepcols}{a character vector of length 2 specifying the names of the horizon depths (e.g. \code{c("hzdept", "hzdepb")}), only necessary if \code{object} is a \code{data.frame}.} +\item{depthcols}{a character vector of length 2 specifying the names of the horizon depths (e.g. \code{c("top", "bottom")}), only necessary if \code{object} is a} + +\item{hzdepcols}{deprecated being replaced by depthcols.} } \value{ Either a \code{SoilProfileCollection} or \code{data.frame} with the original horizon data segmented by depth intervals. There are usually more records in the resulting object, one for each time a segment interval partially overlaps with a horizon. A new column called \code{segment_id} identifying the depth interval is added. @@ -22,7 +27,7 @@ Either a \code{SoilProfileCollection} or \code{data.frame} with the original hor This function segments or subdivides horizon data from a \code{SoilProfileCollection} or \code{data.frame} by depth interval (e.g. \code{c(0, 10)}, \code{c(0, 50)}, or \code{25:100}). This results in horizon records being split at the specified depth intervals, which duplicates the original horizon data but also adds new horizon depths. In addition, labels (i.e. \code{"segment_id"}) are added to each horizon record that correspond with their depth interval (e.g. \code{025-100}). This function is intended to harmonize horizons to a common support (i.e. depth interval) for further aggregation or summary. See the examples. } \details{ -\code{segment()} performs no aggregation or resampling of the source data, rather, labels are added to horizon records for subsequent aggregation or summary. This makes it possible to process a very large number of records outside of the constraints associated with e.g. \code{slice()} or \code{slab()}. +\code{hz_segment()} performs no aggregation or resampling of the source data, rather, labels are added to horizon records for subsequent aggregation or summary. This makes it possible to process a very large number of records outside of the constraints associated with e.g. \code{slice()} or \code{slab()}. } \examples{ @@ -33,7 +38,7 @@ data(sp1) depths(sp1) <- id ~ top + bottom # segment and trim -z <- segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE) +z <- hz_segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE) # display segment labels # note that there are new horizon boundaries at segments @@ -57,7 +62,7 @@ s <- combine(s) a.slab <- slab(s, fm = ~ p1, slab.structure = c(0, 10, 20, 30), slab.fun = mean, na.rm = TRUE) -z <- segment(s, intervals = c(0, 10, 20, 30), trim = TRUE) +z <- hz_segment(s, intervals = c(0, 10, 20, 30), trim = TRUE) z <- horizons(z) z$thick <- z$bottom - z$top @@ -80,22 +85,22 @@ res$diff < 0.001 data(sp5) # segment by upper 25-cm -test1 <- segment(sp5, intervals = c(0, 100)) +test1 <- hz_segment(sp5, intervals = c(0, 100)) print(test1) nrow(test1) print(object.size(test1), units = "Mb") # segment by 1-cm increments -test2 <- segment(sp5, intervals = 0:100) +test2 <- hz_segment(sp5, intervals = 0:100) print(test2) nrow(test2) print(object.size(test2), units = "Mb") # segment and aggregate -test3 <- segment(horizons(sp5), +test3 <- hz_segment(horizons(sp5), intervals = c(0, 5, 15, 30, 60, 100, 200), - hzdepcols = c("top", "bottom") + depthcols = c("top", "bottom") ) test3$hzthk <- test3$bottom - test3$top test3_agg <- by(test3, test3$segment_id, function(x) { @@ -111,7 +116,7 @@ head(test3_agg) } \seealso{ -\code{\link[=dice]{dice()}}, \code{\link[=glom]{glom()}} +\code{\link[=dice]{dice()}}, \code{\link[=glom]{glom()}}, \code{\link[=hz_dissolve]{hz_dissolve()}}, \code{\link[=hz_lag]{hz_lag()}}, \code{\link[=hz_intersect]{hz_intersect()}} } \author{ Stephen Roecker diff --git a/man/hz_to_taxpartsize.Rd b/man/hz_to_taxpartsize.Rd new file mode 100644 index 000000000..3bd9a5ddc --- /dev/null +++ b/man/hz_to_taxpartsize.Rd @@ -0,0 +1,84 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/allocate.R +\name{hz_to_taxpartsize} +\alias{hz_to_taxpartsize} +\title{Allocate Particle Size Class for the Control Section.} +\usage{ +hz_to_taxpartsize( + x, + y, + taxpartsize = "taxpartsize", + clay = "clay", + idcol = "id", + depthcols = c("top", "bottom") +) +} +\arguments{ +\item{x}{a \code{data.frame} containing the original horizon table.} + +\item{y}{a \code{data.frame} containing the particle size control section depths for each idcol.} + +\item{taxpartsize}{\code{character} column name for taxonomic family particle size class.} + +\item{clay}{\code{character} column name for clay percent.} + +\item{idcol}{character: column name of the pedon ID within the object.} + +\item{depthcols}{a character vector of length 2 specifying the names of the horizon depths (e.g. \code{c("top", "bottom")}).} +} +\value{ +A \code{data.frame} object containing the original idcol, the aggregated particle size control section allocation, and an aniso column to indicate more than one contrasting class. +} +\description{ +This function aggregates information in the horizon table and allocates it to the particle size class for the control section. +} +\details{ +This function differs from \code{\link{texture_to_taxpartsize}} in that is aggregates the results of \code{\link{texture_to_taxpartsize}}, and accounts for strongly contrasting particle size classes. +} +\examples{ + +h <- data.frame( + id = 1, + hzname = c("A", "BA", "Bw", "BC", "C"), + top = c(0, 10, 45, 60, 90), + bottom = c(10, 45, 60, 90, 150), + clay = c(15, 16, 45, 20, 10), + sand = c(10, 35, 40, 50, 90), + frags = c(0, 5, 10, 38, 40) +) + +h <- cbind(h, + texcl = ssc_to_texcl(clay = h$clay, sand = h$sand)) + +pscs <- data.frame(id = 1, + top = 25, + bottom = 100) + +h <- cbind(h, + taxpartsize = texture_to_taxpartsize( + texcl = h$texcl, + clay = h$clay, + sand = h$sand, + fragvoltot = h$frags + )) + +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") + +hz_to_taxpartsize(horizons(h), pscs) + + +} +\seealso{ +\code{\link[=texture_to_taxpartsize]{texture_to_taxpartsize()}}, \code{\link[=lookup_taxpartsize]{lookup_taxpartsize()}} +} +\author{ +Stephen Roecker +} diff --git a/man/hzmetaname.Rd b/man/hzmetaname.Rd new file mode 100644 index 000000000..e9350ff62 --- /dev/null +++ b/man/hzmetaname.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/SoilProfileCollection-metadata.R +\docType{methods} +\name{hzmetaname} +\alias{hzmetaname} +\alias{hzmetaname,SoilProfileCollection-method} +\alias{hzmetaname<-} +\alias{hzmetaname<-,SoilProfileCollection-method} +\title{Get or Set Horizon Metadata Column Name} +\usage{ +\S4method{hzmetaname}{SoilProfileCollection}(object, attr, required = FALSE) + +\S4method{hzmetaname}{SoilProfileCollection}(object, attr, required = FALSE) <- value +} +\arguments{ +\item{object}{A \emph{SoilProfileCollection}} + +\item{attr}{\emph{character}. Base name for attribute to be stored in metadata. This is prefixed with \code{"aqp_hz"} for horizon-level metadata for column attributes. e.g. \code{attr="clay"} results in metadata value retrieved from \code{"aqp_hzclay"}.} + +\item{required}{\emph{logical}. Is this attribute required? If it is, set to \code{TRUE} to trigger error on invalid \code{value}.} + +\item{value}{\emph{character}. Name of horizon-level column containing data corresponding to \code{attr}.} +} +\description{ +\code{hzmetaname()}: Get column name containing horizon data of interest + +\verb{hzmetaname<-}: Set horizon designation column name +} +\details{ +Store the column name containing a specific type of horizon data in the metadata slot of the SoilProfileCollection. +} +\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) +} +\seealso{ +\code{\link[=guessHzAttrName]{guessHzAttrName()}} +} diff --git a/man/lookup_taxpartsize.Rd b/man/lookup_taxpartsize.Rd new file mode 100644 index 000000000..117516b42 --- /dev/null +++ b/man/lookup_taxpartsize.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/texture.R +\name{lookup_taxpartsize} +\alias{lookup_taxpartsize} +\title{Ranking Systems for USDA Taxonomic Particle-Size and Substitute Classes of Mineral Soils} +\usage{ +lookup_taxpartsize() +} +\value{ +A data.frame with a rank column, taxonomic family particle size class, and a flag for contrasting. +} +\description{ +Generate a lookup table of USDA Particle-Size and Substitute Classes names, ranked according to approximate particle size +} +\examples{ + +# class codes +lu <- lookup_taxpartsize() + +idx <- lu$contrasting == FALSE + +lu$taxpartsize[idx] + +lu$rank[as.integer(lu$taxpartsize)[idx]] + +} +\references{ +\href{https://nrcspad.sc.egov.usda.gov/DistributionCenter/product.aspx?ProductID=991}{Field Book for Describing and Sampling Soils, version 3.0} +} +\seealso{ +\code{\link[=hz_to_taxpartsize]{hz_to_taxpartsize()}}, \code{\link[=texture_to_taxpartsize]{texture_to_taxpartsize()}}, \code{\link[=SoilTextureLevels]{SoilTextureLevels()}} +} +\author{ +Stephen Roecker +} diff --git a/man/mollic.thickness.requirement.Rd b/man/mollic.thickness.requirement.Rd index c8edd7dfe..5b186b551 100644 --- a/man/mollic.thickness.requirement.Rd +++ b/man/mollic.thickness.requirement.Rd @@ -6,9 +6,9 @@ \usage{ mollic.thickness.requirement( p, - hzdesgn = guessHzDesgnName(p), - texcl.attr = guessHzTexClName(p), - clay.attr = guessHzAttrName(p, "clay", c("total", "_r")), + hzdesgn = hzdesgnname(p, required = TRUE), + texcl.attr = hztexclname(p, required = TRUE), + clay.attr = hzmetaname(p, "clay", required = TRUE), truncate = TRUE ) } diff --git a/man/munsell2rgb.Rd b/man/munsell2rgb.Rd index aacd0b7ec..b34c1cc92 100644 --- a/man/munsell2rgb.Rd +++ b/man/munsell2rgb.Rd @@ -51,67 +51,56 @@ Care should be taken when using the resulting sRGB values; they are close to the \examples{ # neutral hues (N) can be defined with chroma of 0 or NA -g <- expand.grid(hue='N', value=2:8, chroma=0, stringsAsFactors=FALSE) +g <- expand.grid(hue='N', value = 2:8, chroma = 0, stringsAsFactors = FALSE) (m <- munsell2rgb(g$hue, g$value, g$chroma)) soilPalette(m) -# back-transform -rgb2munsell(t(col2rgb(m)) / 255) +# back-transform to Munsell notation +col2Munsell(t(col2rgb(m)) / 255) # basic example -d <- expand.grid(hue='10YR', value=2:8, chroma=1:8, stringsAsFactors=FALSE) +d <- expand.grid(hue = '10YR', value = 2:8, chroma = 1:8, stringsAsFactors = FALSE) d$color <- with(d, munsell2rgb(hue, value, chroma)) # similar to the 10YR color book page -plot(value ~ chroma, data=d, col=d$color, pch=15, cex=3) +plot(value ~ chroma, data = d, col = d$color, pch = 15, cex = 3, las = 1) # multiple pages of hue: -hues <- c('2.5YR','5YR','7.5YR','10YR') -d <- expand.grid(hue=hues, value=c(2, 2.5, 3:8), chroma=seq(2,8,by=2), stringsAsFactors=FALSE) +hues <- c('2.5YR', '5YR', '7.5YR', '10YR') +d <- expand.grid( + hue = hues, + value = c(2, 2.5, 3:8), + chroma = seq(2, 8, by = 2), + stringsAsFactors = FALSE +) # convert Munsell -> sRGB d$color <- with(d, munsell2rgb(hue, value, chroma)) # extract CIELAB coordinates -with(d, munsell2rgb(hue, value, chroma, returnLAB=TRUE)) +with(d, munsell2rgb(hue, value, chroma, returnLAB = TRUE)) # plot: note that we are setting panel order from red --> yellow library(lattice) -xyplot(value ~ factor(chroma) | factor(hue, levels=hues), - main="Common Soil Colors", layout=c(4,1), scales=list(alternating=1), - strip=strip.custom(bg=grey(0.85)), - data=d, as.table=TRUE, subscripts=TRUE, xlab='Chroma', ylab='Value', - panel=function(x, y, subscripts, ...) - { - panel.xyplot(x, y, pch=15, cex=4, col=d$color[subscripts]) - } +xyplot( + value ~ factor(chroma) | factor(hue, levels = hues), + main = "Common Soil Colors", layout = c(4, 1), scales = list(alternating = 1), + strip = strip.custom(bg = grey(0.85)), + data = d, as.table = TRUE, subscripts = TRUE, + xlab = 'Chroma', ylab = 'Value', + panel = function(x, y, subscripts, ...) { + panel.xyplot(x, y, pch = 15, cex = 4, col = d$color[subscripts]) + } ) -# soils example -data(sp1) - -# convert colors -sp1$soil_color <- with(sp1, munsell2rgb(hue, value, chroma)) - -# simple plot, may need to tweak gamma-correction... -image(matrix(1:nrow(sp1)), axes=FALSE, col=sp1$soil_color, main='Soil Colors') - -# convert into a more useful color space -# you will need the colorspace package for this to work -if(require(colorspace)) { - # keep RGB triplets from conversion - sp1.rgb <- with(sp1, munsell2rgb(hue, value, chroma, return_triplets=TRUE)) - - # convert into LAB color space - sp1.lab <- as(with(sp1.rgb, sRGB(r,g,b)), 'LAB') - plot(sp1.lab) -} # convert a non-standard color to closest "chip" in `munsell` look-up table getClosestMunsellChip('7.9YR 2.7/2.0', convertColors = FALSE) -# convert directly to R color + +# convert directly to hex notation of sRGB getClosestMunsellChip('7.9YR 2.7/2.0') + } \references{ \itemize{ diff --git a/man/plot_distance_graph.Rd b/man/plot_distance_graph.Rd index 8ba2f8cc6..fdef71127 100644 --- a/man/plot_distance_graph.Rd +++ b/man/plot_distance_graph.Rd @@ -39,7 +39,7 @@ plot_distance_graph(d, idx=7:12) plot_distance_graph(d, idx=12:18) } \references{ -http://casoilresource.lawr.ucdavis.edu/ +https://casoilresource.lawr.ucdavis.edu/ } \seealso{ \code{\link{sp2}}, \code{\link{profile_compare}} diff --git a/man/profile_compare.Rd b/man/profile_compare.Rd index c2cfbc7cb..95e73e75d 100644 --- a/man/profile_compare.Rd +++ b/man/profile_compare.Rd @@ -151,7 +151,7 @@ mentioned depth-slicing algorithm. } } \seealso{ -\code{\link{slice}}, \code{\link{daisy}} +\code{\link[=dice]{dice()}}, \code{\link[cluster:daisy]{cluster::daisy()}} } \author{ Dylan E. Beaudette diff --git a/man/restrictions-set.Rd b/man/restrictions-set.Rd deleted file mode 100644 index 5b4f4c83e..000000000 --- a/man/restrictions-set.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SoilProfileCollection-setters.R -\docType{methods} -\name{restrictions<-} -\alias{restrictions<-} -\alias{restrictions<-,SoilProfileCollection-method} -\title{Add Data to Restrictions Slot} -\usage{ -\S4method{restrictions}{SoilProfileCollection}(object) <- value -} -\arguments{ -\item{object}{A SoilProfileCollection} - -\item{value}{An object inheriting \code{data.frame}} -} -\description{ -Restrictions data in an object inheriting from \code{data.frame} can easily be added via merge (LEFT JOIN). There must be one or more same-named profile ID columns on the left and right hand side to facilitate the join: \code{restrictions(spc) <- newdata}. -} -\examples{ - -# load test data -data(sp2) - -# promote to SPC -depths(sp2) <- id ~ top + bottom - -# assign abrupt textural change to a profile -newdata <- data.frame(id = c("hon-21"), - restrkind = "abrupt textural change", - restrdep = 46) - -# do left join -restrictions(sp2) <- newdata - -# inspect site table: newvalue TRUE only for horizons -# with top depth equal to zero -restrictions(sp2) - -} diff --git a/man/restrictions.Rd b/man/restrictions.Rd index bebe38ef3..d003e07bd 100644 --- a/man/restrictions.Rd +++ b/man/restrictions.Rd @@ -1,16 +1,51 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Class-SoilProfileCollection.R +% Please edit documentation in R/Class-SoilProfileCollection.R, +% R/SoilProfileCollection-setters.R \docType{methods} \name{restrictions,SoilProfileCollection-method} \alias{restrictions,SoilProfileCollection-method} \alias{restrictions} -\title{Retrieve restriction data from SoilProfileCollection} +\alias{restrictions<-} +\alias{restrictions<-,SoilProfileCollection-method} +\title{Get or Set Restriction data in a SoilProfileCollection} \usage{ \S4method{restrictions}{SoilProfileCollection}(object) + +\S4method{restrictions}{SoilProfileCollection}(object) <- value } \arguments{ -\item{object}{a SoilProfileCollection} +\item{object}{A SoilProfileCollection} + +\item{value}{An data.frame object containing at least a column with name \code{idname(object)}} } \description{ -Get restriction data from SoilProfileCollection. Result is returned in the same \code{data.frame} class used to initially construct the SoilProfileCollection. +Restrictions describe root-limiting features in the soil. A single profile may have multiple restrictions. +\itemize{ +\item \code{restrictions()} (get method): Get restriction data from a SoilProfileCollection. +} + +\itemize{ +\item \verb{restrictions<-} (set method): Set restriction data for a SoilProfileCollection. The profile ID column from \code{object} (\code{idname(object)}) must be present in the replacement \code{value} object. +} +} +\examples{ + +# load test data +data(sp2) + +# promote to SPC +depths(sp2) <- id ~ top + bottom + +# assign abrupt textural change to a profile +newdata <- data.frame(id = c("hon-21"), + restrkind = "abrupt textural change", + restrdep = 46) + +# do left join +restrictions(sp2) <- newdata + +# inspect site table: newvalue TRUE only for horizons +# with top depth equal to zero +restrictions(sp2) + } diff --git a/man/simulateColor.Rd b/man/simulateColor.Rd index faa40bbf3..a3635e056 100644 --- a/man/simulateColor.Rd +++ b/man/simulateColor.Rd @@ -4,20 +4,26 @@ \alias{simulateColor} \title{Simulate Soil Colors} \usage{ -simulateColor(method = c("dE00", "proportions"), n, parameters, SPC = NULL) +simulateColor( + method = c("dE00", "proportions", "mvnorm"), + n, + parameters, + SPC = NULL +) } \arguments{ \item{method}{simulation method, see details} -\item{n}{number of simulated colors per horizon} +\item{n}{number of simulated colors per group} \item{parameters}{a \code{list}, format depends on \code{method}: \itemize{ -\item \code{proportions}: output from \code{\link{aggregateColor}} +\item \code{proportions}: output from \code{\link[=aggregateColor]{aggregateColor()}} \item \code{dE00}: formatted as \code{list(m = '7.5YR 3/3', thresh = 5, hues = c('7.5YR'))} +\item \code{mvnorm}: formatted as \code{list(hvc = x)} } -Where \code{m} is a single representative Munsell chip, \code{thresh} is a threshold specified in CIE2000 color contrast (dE00), and \code{hues} is a vector of allowed Munsell hues.} +Where \code{m} is a single representative Munsell chip, \code{thresh} is a threshold specified in CIE2000 color contrast (dE00), \code{hues} is a vector of allowed Munsell hues, and \code{x} is a \code{data.frame} representing columns of Munsell hue, value, and chroma having at least 3 rows.} \item{SPC}{\code{SoilProfileCollection}, attempt to modify \code{SPC} with simulated colors} } @@ -25,7 +31,12 @@ Where \code{m} is a single representative Munsell chip, \code{thresh} is a thres a \code{list}, unless \code{SPC} is specified, then a \code{SoilProfileCollection} object } \description{ -Simulate plausible soil colors based on proportions by Munsell "chip", or using a seed Munsell chip and threshold specified via CIE2000 color contrast metric. +Simulate plausible soil colors based on several possible parameterization of a "range in characteristics" (RIC). Soil color RIC can be specified by a list of parameters: +\itemize{ +\item soil color proportions, as output from \code{\link[=aggregateColor]{aggregateColor()}} -- \code{method = 'proportions'} +\item most likely Munsell color, CIE2000 threshold, and vector of acceptable hues -- \code{method = 'dE00'} +\item \code{data.frame} of Munsell hue, value, and chroma representing observed soil colors -- \code{method = 'mvnorm'} +} } \examples{ diff --git a/man/soilTextureColorPal.Rd b/man/soilTextureColorPal.Rd new file mode 100644 index 000000000..b8c859148 --- /dev/null +++ b/man/soilTextureColorPal.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/color-palettes.R +\name{soilTextureColorPal} +\alias{soilTextureColorPal} +\title{Soil Texture Color Palettes} +\usage{ +soilTextureColorPal(simplify = FALSE, schema = "soilweb") +} +\arguments{ +\item{simplify}{logical, return the base 12 (\code{TRUE}) or full 21 (\code{FALSE}) soil texture classes} + +\item{schema}{select mapping between soil texture classes, and colors, currently limited to 'soilweb'} +} +\value{ +\code{data.frame} from soil texture class codes and colors +} +\description{ +Suggested color palettes for USDA soil texture classes, ranked according to average plant-available water holding capacity. The default color mapping schema is based on a palette used by SoilWeb applications. +} +\examples{ + +# base 12 soil texture classes +# ranked by plant available water-holding capacity +d <- soilTextureColorPal(simplify = TRUE) +soilPalette(d$color, lab = d$class, lab.cex = 1) + +# full 21 soil texture classes +# ranked by plant available water-holding capacity +d <- soilTextureColorPal(simplify = FALSE) +soilPalette(d$color, lab = d$class, lab.cex = 1) + +} +\author{ +D.E. Beaudette, Mike Walkinshaw, A.T. O'Geen +} diff --git a/man/sp1.Rd b/man/sp1.Rd index 39a1f0b2e..4c9af583e 100644 --- a/man/sp1.Rd +++ b/man/sp1.Rd @@ -55,6 +55,6 @@ panel=panel.superpose, ylim=c(110,-5), asp=2) } \references{ -\url{http://casoilresource.lawr.ucdavis.edu/} +\url{https://casoilresource.lawr.ucdavis.edu/} } \keyword{datasets} diff --git a/man/sp2.Rd b/man/sp2.Rd index 8cc3eaddf..304c6295f 100644 --- a/man/sp2.Rd +++ b/man/sp2.Rd @@ -81,7 +81,7 @@ legend('topleft', legend=levels(sp2$surface), col=1:6, pch=15, bty='n', bg='whit } \references{ -\url{http://casoilresource.lawr.ucdavis.edu/} +\url{https://casoilresource.lawr.ucdavis.edu/} } \author{ Dylan E. Beaudette diff --git a/man/sp3.Rd b/man/sp3.Rd index 358163c19..26e0912fc 100644 --- a/man/sp3.Rd +++ b/man/sp3.Rd @@ -148,6 +148,6 @@ plotSPC( } } \references{ -\url{http://casoilresource.lawr.ucdavis.edu/} +\url{https://casoilresource.lawr.ucdavis.edu/} } \keyword{datasets} diff --git a/man/texture.Rd b/man/texture.Rd index a1cc39446..06777da14 100644 --- a/man/texture.Rd +++ b/man/texture.Rd @@ -25,6 +25,7 @@ texture_to_taxpartsize( texcl = NULL, clay = NULL, sand = NULL, + sandvf = NULL, fragvoltot = NULL ) @@ -75,6 +76,8 @@ conventions (e.g. gr|GR, grv|GRV)} code conventions (e.g. gr|GR, pg|PG), only used when fragments or artifacts are > 90 percent by volume (default: NULL))} +\item{sandvf}{vector of very fine sand percentages} + \item{fragvoltot}{vector of total rock fragment percentages} \item{texture}{vector of combinations of texcl, texmod, and lieutex (e.g. CL, GR-CL, CBV-S, GR)} @@ -275,6 +278,11 @@ fragvol_to_texmod(gravel = 10, cobbles = 10) \references{ Matthew R. Levi, Modified Centroid for Estimating Sand, Silt, and Clay from Soil Texture Class, Soil Science Society of America Journal, 2017, 81(3):578-588, ISSN 1435-0661, \doi{10.2136/sssaj2016.09.0301}. } +\seealso{ +\code{\link{SoilTextureLevels}} + +\code{\link[=hz_to_taxpartsize]{hz_to_taxpartsize()}}, \code{\link[=lookup_taxpartsize]{lookup_taxpartsize()}} +} \author{ Stephen Roecker } diff --git a/man/thicknessOf.Rd b/man/thicknessOf.Rd new file mode 100644 index 000000000..c3f74c384 --- /dev/null +++ b/man/thicknessOf.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/thicknessOf.R +\name{thicknessOf} +\alias{thicknessOf} +\title{Calculate Thickness of Horizons Matching Logical Criteria} +\usage{ +thicknessOf( + x, + pattern = NULL, + hzdesgn = hzdesgnname(x, required = TRUE), + method = "cumulative", + prefix = "", + thickvar = "thickness", + depthvars = horizonDepths(x), + FUN = function(x, pattern, hzdesgn, ...) grepl(pattern, x[[hzdesgn]]), + na.rm = FALSE, + ... +) +} +\arguments{ +\item{x}{A \emph{SoilProfileCollection}} + +\item{pattern}{\emph{character}. A pattern to match in \code{hzdesgn}; used with the default \code{FUN} definition for regular expression pattern matching on horizons.} + +\item{hzdesgn}{\emph{character}. A column containing horizon designations or other horizon-level character label used to identify matches; used with the default \code{FUN} definition.} + +\item{method}{\emph{character}. Either \code{"cumulative"} (default) or \code{"minmax"}. See details.} + +\item{prefix}{\emph{character}. Column prefix for calculated \code{thickvar} (and \code{depthvar} for \code{method="minmax"}) column results. Default: \code{""}.} + +\item{thickvar}{\emph{character} Length \code{1}. Column name to use for calculated thickness column. Default: \code{"thickness"}} + +\item{depthvars}{\emph{character}. Length \code{2}. Column names to use for calculated minimum top depth and maximum bottom depth in \code{method="minmax"}. Default: \code{horizonDepths(x)}} + +\item{FUN}{\emph{function}. A function that returns a \emph{logical} vector equal in length to the number of horizons in \code{x}. See details.} + +\item{na.rm}{\emph{logical}. Omit \code{NA} values in summaries of thickness and in matching? Default: \code{FALSE}} + +\item{...}{Additional arguments passed to the matching function \code{FUN}.} +} +\value{ +A \emph{data.frame}-like object (corresponding to the \code{aqp_df_class()} of \code{x}) with one row per profile in \code{x}. First column is always the profile ID which is followed by \code{"thickness"}. In \code{method="minmax"} the upper and lower boundaries used to calculate \code{"thickness"} are also returned as \code{"tmin"} and \code{"tmax"} columns, respectively. +} +\description{ +This function calculates the cumulative (\code{method="cumulative"}, default) or maximum difference between (\code{method="minmax"}) horizons within a profile that match a defined pattern (\code{pattern}) or, more generally, any set of horizon-level logical expressions encoded in a function (\code{FUN}). +} +\details{ +The two thickness methods currently available are: +\itemize{ +\item \code{method="cumulative"} (default): cumulative thickness of horizons where \code{FUN} returns true +\item \code{method="minmax"}: maximum bottom depth minus minimum top depth of horizons where \code{FUN} returns true +} + +If a custom function (\code{FUN}) is used, it should accept arbitrary additional arguments via an ellipsis (\code{...}). +It is not necessary to do anything with arguments, but the result should match the number of horizons found in the input SoilProfileCollection \code{x}. +} +\examples{ +data("jacobs2000") + +# cumulative thickness of horizon designations matching "Bt" +thicknessOf(jacobs2000, "Bt") + +# maximum bottom depth minus minimum top depth of horizon designations matching "Bt" +thicknessOf(jacobs2000, "Bt", prefix = "Bt_", method = "minmax") + +# cumulative thickness of horizon designations matching "A|B" +thicknessOf(jacobs2000, "A|B", prefix = "AorB_") + +# maximum bottom depth minus minimum top depth of horizon designations matching "A|B" +thicknessOf(jacobs2000, "A|B", method = "minmax", prefix = "AorB_") +# note that the latter includes the thickness of E horizons between the A and the B + +# when using a custom function (be sure to accept ... and consider the effect of NA values) + +# calculate cumulative thickness of horizons containing >18\% clay +thicknessOf(jacobs2000, prefix = "claygt18_", + FUN = function(x, ...) !is.na(x[["clay"]]) & x[["clay"]] > 18) + +} diff --git a/man/thompson.bell.darkness.Rd b/man/thompson.bell.darkness.Rd index a6a95595c..a772a326a 100644 --- a/man/thompson.bell.darkness.Rd +++ b/man/thompson.bell.darkness.Rd @@ -6,7 +6,7 @@ \usage{ thompson.bell.darkness( p, - name = guessHzDesgnName(p, required = TRUE), + name = hzdesgnname(p, required = TRUE), pattern = "^A", value = "m_value", chroma = "m_chroma" diff --git a/man/unroll.Rd b/man/unroll.Rd index 4bad22e39..fca291a17 100644 --- a/man/unroll.Rd +++ b/man/unroll.Rd @@ -49,7 +49,7 @@ plot(x, 1:length(x), ylim=c(90,0), type='b', cex=0.5) } \references{ -http://casoilresource.lawr.ucdavis.edu/ +https://casoilresource.lawr.ucdavis.edu/ } \author{ Dylan E. Beaudette diff --git a/misc/sandbox/RIC-as-color-wheel.R b/misc/sandbox/RIC-as-color-wheel.R index 611a9d18e..b045f46fd 100644 --- a/misc/sandbox/RIC-as-color-wheel.R +++ b/misc/sandbox/RIC-as-color-wheel.R @@ -4,6 +4,8 @@ ## use output from simulateColor() or aggregateColor() vs. manual tabulation +## TODO: update with latest changes to simulateColor() + library(aqp) library(soilDB) diff --git a/misc/sandbox/auto-panel-sketches.R b/misc/sandbox/auto-panel-sketches.R index 2f0bc534a..0e144fadb 100644 --- a/misc/sandbox/auto-panel-sketches.R +++ b/misc/sandbox/auto-panel-sketches.R @@ -30,7 +30,7 @@ z$.chunk <- makeChunks(seq_along(z), size = .size) ## TODO: this doesn't work for thematic sketches, as each panel gets its own legend -par(mar = c(0, 0, 0, 2), mfrow = c(.n, 1)) +par(mar = c(0, 0, 0, 0), mfrow = c(.n, 1)) for(i in .chunkIds) { .idx <- which(z$.chunk == i) @@ -41,8 +41,8 @@ for(i in .chunkIds) { lwd = 0.1, divide.hz = FALSE, width = 0.4, - max.depth = 110, - depth.axis = list(line = -4, cex = 1), + max.depth = 150, + depth.axis = FALSE, n = .size, # color = 'texcl' # color = 'p1' diff --git a/misc/sandbox/bootstrap-texture-eval.R b/misc/sandbox/bootstrap-texture-eval.R index d17640ba0..08a0563ae 100644 --- a/misc/sandbox/bootstrap-texture-eval.R +++ b/misc/sandbox/bootstrap-texture-eval.R @@ -40,6 +40,37 @@ legend('top', legend = c('Source', 'Dirichlet', 'Multivariate Normal'), pch = c( stats.full <- textureTriangleSummary(s.d, pch = 1, cex = 0.5, range.alpha = 50, col = grey(0.5), legend = TRUE, main = 'Original') +data("soiltexture") + +# doesn't work +g <- soiltexture$values[, 1:3] +names(g) <- names(s.d) +z <- kdeDirichlet(s.d, kdegrid = g) + +z <- kdeDirichlet(s.n, n = 100) +image(z) + + +z <- TT.kde2d(TT, tri.data = s.d, n = 100) + +TT <- TT.plot( + class.sys= "USDA-NCSS.TT", + main= "", + tri.sum.tst=FALSE, + cex.lab=0.75, + cex.axis=0.75, + frame.bg.col='white', + class.lab.col='black', + lwd.axis=1.5, + arrows.show=TRUE, + new.mar = c(3, 0, 0, 0) +) +TT.points(tri.data = s.d, geo = TT, col='firebrick', pch = 3, cex = 0.5, lwd = 1, tri.sum.tst = FALSE) +TT.contour(TT, z, add = TRUE, levels = c(0.00001, 0.001, 0.01)) + + + + # sample data @@ -51,13 +82,14 @@ ssc <- horizons(sp4)[grep('^Bt', sp4$name), c('sand', 'silt', 'clay')] names(ssc) <- toupper(names(ssc)) # ok fine, I'll try dplyr -ssc <- horizons(sp4) %>% - filter(grepl('^Bt', x = name)) %>% - select( - SAND = sand, - SILT = silt, - CLAY = clay - ) +# ssc <- horizons(sp4) |> +# subset(grepl('^Bt', x = name)) |> +# transform( +# SAND = sand, +# SILT = silt, +# CLAY = clay +# ) |> +# subset(subset = c('SAND', 'SILT', 'CLAY')) # simulate 100 samples s.d <- bootstrapSoilTexture(ssc, n = 100, method = 'dirichlet')$samples diff --git a/misc/sandbox/clarksville.R b/misc/sandbox/clarksville.R index 321def3a4..aa0e2e156 100644 --- a/misc/sandbox/clarksville.R +++ b/misc/sandbox/clarksville.R @@ -30,7 +30,7 @@ aggregateColorPlot(a.8, label.cex = 0.65, main = "Clarksville Moist Colors\nGene # marginal quantiles and L1 median of {L,A,B} x <- colorQuantiles(na.omit(pedons$moist_soil_color[which(pedons$genhz == 'Bt')])) -plotColorQuantiles(x, title = 'Clarksville - Bt') +plotColorQuantiles(x) ## RI as described in Barron and Torrent, 1986 @@ -40,7 +40,8 @@ pedons$ln_RI <- log(pedons$RI) hist(pedons$ln_RI) -plot(sample(pedons, 25), color='ln_RI') +par(mar = c(0, 0, 0, 2)) +plotSPC(sample(pedons, 15), color = 'moist_soil_color', max.depth = 150, width = 0.35, name.style = 'center-center') diff --git a/misc/sandbox/demo-hz-subsetting-functionality.R b/misc/sandbox/demo-hz-subsetting-functionality.R new file mode 100644 index 000000000..55f963707 --- /dev/null +++ b/misc/sandbox/demo-hz-subsetting-functionality.R @@ -0,0 +1,99 @@ +library(aqp) + + +# example SPC from data.frame +data(sp4) +depths(sp4) <- id ~ top + bottom +hzdesgnname(sp4) <- 'name' + + +# test effect of potential sorting alpha vs. numeric +# all seem to work + + +# profile_id(sp4) <- as.character(1:length(sp4)) + +profile_id(sp4) <- sprintf("%0.2d", 1:length(sp4)) + +# profile_id(sp4) <- letters[1:length(sp4)] + + +testIt <- function(spc, top, bottom) { + + # keep old ID + spc$.oldID <- profile_id(spc) + + # various approaches + + # dice() fills missing depth intervals with NA + # default when given a formula + .fm <- as.formula(sprintf("%s:%s ~ .", top, bottom - 1)) + d <- dice(spc, fm = .fm) + + # force filling missing depth intervals with NA + g <- glom(spc, z1 = top, z2 = bottom, fill = TRUE) + gt <- glom(spc, z1 = top, z2 = bottom, truncate = TRUE, fill = TRUE) + + # single NA horizon, with NA depths + st <- hz_segment(spc, intervals = c(top, bottom)) + s <- hz_segment(spc, intervals = c(top, bottom), trim = FALSE) + + + # normalize profile IDs + # so that all can be combined / viewed together in a single SPC + profile_id(d) <- sprintf("%s\nD", profile_id(d)) + profile_id(g) <- sprintf("%s\nG", profile_id(g)) + profile_id(gt) <- sprintf("%s\nGT", profile_id(gt)) + profile_id(s) <- sprintf("%s\nS", profile_id(s)) + profile_id(st) <- sprintf("%s\nST", profile_id(st)) + profile_id(spc) <- sprintf("%s\n", profile_id(spc)) + + x <- combine(spc, d, g, gt, s, st) + + par(mar = c(0, 0, 3, 0)) + + plotSPC(x, color = 'CEC_7', name.style = 'center-center', width = 0.4, id.style = 'top', col.palette = hcl.colors(25, palette = 'viridis'), depth.axis = list(line = -5)) + + segments(x0 = 0, x1 = length(x) + 1, y0 = c(top, bottom), y1 = c(top, bottom), lwd = 2, lty = 3, col = 'red') + + invisible(x) + +} + +testIt(sp4, top = 0, bottom = 25) +# check for all-NA horizons, and equal number of sites / original ID +table(a$.oldID) + + +a <- testIt(sp4, top = 15, bottom = 35) +# check for all-NA horizons, and equal number of sites / original ID +table(a$.oldID) + + +a <- testIt(sp4, top = 20, bottom = 21) +# check for all-NA horizons, and equal number of sites / original ID +table(a$.oldID) + + +a <- testIt(sp4, top = 50, bottom = 60) +# check for all-NA horizons, and equal number of sites / original ID +table(a$.oldID) + + + + +# +# # rough estimate of function run time, on a lager collection +# z <- duplicate(sp4, times = 100) +# library(microbenchmark) +# +# m <- microbenchmark( +# dice = dice(z, (.top):(.bottom - 1) ~ .), +# glom = glom(z, z1 = .top, z2 = .bottom, truncate = TRUE), +# hz_segment = hz_segment(sp4, intervals = c(.top, .bottom), trim = TRUE), +# times = 10 +# ) +# +# m + + diff --git a/misc/sandbox/mps-smooth-soil-color.R b/misc/sandbox/mps-smooth-soil-color.R new file mode 100644 index 000000000..ed93a4a1d --- /dev/null +++ b/misc/sandbox/mps-smooth-soil-color.R @@ -0,0 +1,81 @@ +library(aqp) +library(mpspline2) + +# example soil profile with some wild colors +x <- list( + id = 'P1', + depths = c(5, 25, 33, 100, 150), + name = c('A', 'Bt1', 'Bt2', 'BC', 'Cr'), + p1 = c(5, 25, 35, 10, 8), + color = c('10YR 2/1', '7.5YR 3/3', '2.5Y 8/2', '2.5YR 4/6', '5G 6/3'), + hzd = c('clear', 'clear', 'abrupt', 'gradual', NA) +) + +# init SPC +x <- quickSPC(x) +x$hzd <- hzDistinctnessCodeToOffset(x$hzd) + +# convert Munsell -> sRGB in hex notation +x$col_source <- parseMunsell(x$color) + +# convert Munsell -> CIELAB +.lab <- parseMunsell(x$color, convertColors = TRUE, returnLAB = TRUE) + +# shortcut to splice-in CIELAB color coordinates +replaceHorizons(x) <- cbind(horizons(x), .lab) + +# check +plotSPC(x, color = 'L', hz.distinctness.offset = 'hzd') + +# hack to smooth multiple variables +# future enhancement to spc2mpspline() +.lambda <- 0.1 +.spcL <- spc2mpspline(x, var_name = 'L', lam = .lambda, method = 'est_1cm') +.spcA <- spc2mpspline(x, var_name = 'A', lam = .lambda, method = 'est_1cm') +.spcB <- spc2mpspline(x, var_name = 'B', lam = .lambda, method = 'est_1cm') + +m <- .spcL +m$A_spline <- .spcA$A_spline +m$B_spline <- .spcB$B_spline + + +# check +# ... negative numbers truncated at 0 +par(mar = c(0, 0, 3, 3)) +plotSPC(m, color = 'L_spline', name = NA, lwd = 0, divide.hz = FALSE) +plotSPC(m, color = 'A_spline', name = NA, lwd = 0, divide.hz = FALSE) +plotSPC(m, color = 'B_spline', name = NA, lwd = 0, divide.hz = FALSE) + +# back-transform to Munsell at this point +.lab <- horizons(m)[, c('L_spline', 'A_spline', 'B_spline')] +names(.lab) <- c('L', 'A', 'B') + +# interesting... +.mun <- col2Munsell(.lab, space = 'CIELAB') +table(.mun$hue) +table(.mun$value) +table(.mun$chroma) + +# convert smoothed CIELAB -> sRGB +.srgb <- convertColor(horizons(m)[, c('L_spline', 'A_spline', 'B_spline')], from = 'Lab', to = 'sRGB', from.ref.white = 'D65', to.ref.white = 'D65') + +# sRGB -> hex notation +m$col_spline <- rgb(.srgb, maxColorValue = 1) + +# ok +plotSPC(m, color = 'col_spline', name = NA, lwd = 0, divide.hz = FALSE) + +# normalize names and combine SPCs +m$soil_color <- m$col_spline +x$soil_color <- x$col_source + +profile_id(m) <- 'P1-EA Spline' + +z <- combine(x, m) + +# compare side by side +par(mar = c(0, 0, 0, 3)) +plotSPC(z, color = 'soil_color', name = NA, lwd = 0, divide.hz = FALSE, cex.names = 1) + +# green hues lost due to truncation of smoothed values at x>=0 + diff --git a/misc/sandbox/mps2-lambda-eval.R b/misc/sandbox/mps2-lambda-eval.R index 22019e072..724dcc734 100644 --- a/misc/sandbox/mps2-lambda-eval.R +++ b/misc/sandbox/mps2-lambda-eval.R @@ -1,26 +1,104 @@ # install mpsline2 from CRAN library(aqp) +library(soilDB) library(sharpshootR) library(mpspline2) library(reshape2) library(lattice) -# make some example data -ids <- LETTERS[1] -set.seed(10101) -x <- lapply(ids, random_profile, n = c(6, 7, 8), n_prop = 1, method = 'LPP', SPC = TRUE, lpp.a = 5, lpp.b = 25, lpp.d = 10, lpp.e = 5, lpp.u = 25) -x <- combine(x) +# x <- fetchKSSL(series = 'clarksville') +# +# plotSPC(x[2, ], color = 'clay') +# +# x <- x[2, ] +# x$p1 <- x$clay +# x$top <- x$hzn_top +# x$bottom <- x$hzn_bot +# profile_id(x) <- 'clarksville' +# horizonDepths(x) <- c('top', 'bottom') + + +# # # make some example data +# ids <- LETTERS[1:3] +# +# set.seed(10101) +# x <- lapply( +# ids, +# random_profile, +# n = c(6, 7, 8), +# n_prop = 1, +# method = 'LPP', +# SPC = TRUE, +# lpp.a = 5, +# lpp.b = 30, +# lpp.d = 10, +# lpp.e = 5, +# lpp.u = 25 +# ) +# +# x <- combine(x) +# horizons(x)$hzd <- 0 +# site(x)$group <- profile_id(x) + + + +## example data + +x <- list( + id = 'P1', + depths = c(5, 25, 33, 100, 150), + name = c('A', 'Bt1', 'Bt2', 'BC', 'Cr'), + p1 = c(5, 25, 35, 10, 8), + soil_color = c('10YR 2/2', '10YR 3/3', '10YR 4/4', '10YR 4/6', '5G 6/2'), + hzd = c('clear', 'clear', 'abrupt', 'gradual', NA) +) + +x <- quickSPC(x) +x$hzd <- hzDistinctnessCodeToOffset(x$hzd) +site(x)$group <- 'A' + + +## wait for this to be fixed +# https://github.com/obrl-soil/mpspline2/issues/9 +# x$p1 <- scale(x$p1) + + + +## PAWS example +# +# x <- list( +# id = 'P1', +# depths = c(5, 25, 33, 100, 150), +# name = c('A', 'Bt1', 'Bt2', 'BC', 'Cr'), +# awc_r = c(0.11, 0.15, 0.18, 0.08, 0.05), +# soil_color = c('10YR 2/2', '10YR 3/3', '10YR 4/4', '10YR 4/6', '5G 6/2'), +# hzd = c('clear', 'clear', 'abrupt', 'gradual', NA) +# ) +# +# +# x <- quickSPC(x) +# x$hzd <- hzDistinctnessCodeToOffset(x$hzd) +# +# x$p1 <- (x$bottom - x$top) * x$awc_r + + + # fake site data site(x)$fake_site_attr <- 1:length(x) + +.cols <- hcl.colors(50, 'spectral') + # check source data -par(mar=c(0,0,3,1)) -plotSPC(x, color='p1', col.palette = hcl.colors(10, 'viridis')) +par(mar = c(0, 0, 3, 1)) +plotSPC(x, color = 'p1', col.palette = .cols, hz.distinctness.offset = 'hzd') -s <- seq(0, 1, by = 0.25) +# iterate over possible lambda values +# 0.1 is default +s <- c(0.1, 0.25, 0.3, 0.5, 1) m <- lapply(s, function(i) { .spc <- spc2mpspline(x, var_name = 'p1', lam = i, method = 'est_1cm') profile_id(.spc) <- sprintf("%s-0%s", profile_id(.spc), i) @@ -32,35 +110,77 @@ z$p1 <- z$p1_spline xx <- combine(z, x) +# site(xx)$id <- profile_id(xx) + + par(mar = c(0, 0, 3, 1)) -plotSPC(xx, color = 'p1', col.palette = hcl.colors(10, 'viridis'), divide.hz = FALSE, width = 0.35) + +plotSPC(xx, color = 'p1', col.palette = .cols, divide.hz = FALSE, width = 0.35, name = NA, lwd = 0, hz.distinctness.offset = 'hzd') o <- order(xx$p1_rmse) -plotSPC(xx, color = 'p1', col.palette = hcl.colors(10, 'viridis'), divide.hz = FALSE, width = 0.35, plot.order = o) +plotSPC(xx, color = 'p1', col.palette = .cols, divide.hz = FALSE, width = 0.35, plot.order = o, name = NA, lwd = 0, hz.distinctness.offset = 'hzd') + + +.cols <- c(hcl.colors(n = 5), 'firebrick') +tps <- tactile::tactile.theme(superpose.line = list(lwd = 2, col = .cols)) +site(xx)$lambda <- factor(c('original', s)) -tps <- tactile::tactile.theme(superpose.line = list(lwd = 2)) # compare depth-functions by method, no aggregation -xyplot(cbind(top, bottom) ~ p1, id=xx$id, groups = factor(id), - data=as(xx, 'data.frame'), - par.settings=tps, - auto.key=list(columns=3, lines=TRUE, points=FALSE), - strip=strip.custom(bg=grey(0.85)), - ylim=c(125, -5), as.table=TRUE, panel=panel.depth_function, - scales = list(alternating = 1), - asp = 1 +xyplot( + cbind(top, bottom) ~ p1 | group, + id = factor(xx$id), + groups = lambda, + data = as(xx, 'data.frame'), + par.settings = tps, + auto.key = list(columns = 1, lines = TRUE, points = FALSE, title = 'lambda', space = 'right', cex = 0.8), + strip = strip.custom(bg = grey(0.85)), + ylim = c(160, -5), + ylab = 'Depth (cm)', + # main = '', + as.table = TRUE, + panel = panel.depth_function, + scales = list(alternating = 1, y = list(tick.number = 15)), + asp = 2 ) -xyplot(cbind(top, bottom) ~ p1 | id, id=xx$id, - data=as(xx, 'data.frame'), - par.settings=tps, - auto.key=list(columns=4, lines=TRUE, points=FALSE), - strip=strip.custom(bg=grey(0.85)), - ylim=c(125, -5), as.table=TRUE, panel=panel.depth_function, - layout = c(6, 1), - scales = list(alternating = 1) + +# note: can only be used on single-profile groups +slabInterval <- function(i, .f = sum) { + .ss <- as.numeric(strsplit(i, '-', fixed = TRUE)[[1]]) + + .a <- slab(xx, lambda ~ p1, slab.structure = .ss, slab.fun = .f, na.rm = TRUE) + .a <- dcast(.a, lambda ~ variable, value.var = 'value') + names(.a)[2] <- i + + return(.a) +} + +l <- lapply( + c('0-150', '25-50', '75-100', '0-25', '0-75'), + slabInterval ) +a <- Reduce(merge, l) + + +knitr::kable(a, row.names = FALSE, digits = 0, caption = 'Sum of values over depth interval.') + + +# xyplot(cbind(top, bottom) ~ p1 | id, id=xx$id, +# data=as(xx, 'data.frame'), +# par.settings=tps, +# auto.key=list(columns=4, lines=TRUE, points=FALSE), +# strip=strip.custom(bg=grey(0.85)), +# ylim=c(150, -5), as.table=TRUE, panel=panel.depth_function, +# layout = c(6, 1), +# scales = list(alternating = 1) +# ) +# +# +# +# +# diff --git a/misc/sandbox/profile-ACF-ideas.R b/misc/sandbox/profile-ACF-ideas.R index c30d89643..10634f61f 100644 --- a/misc/sandbox/profile-ACF-ideas.R +++ b/misc/sandbox/profile-ACF-ideas.R @@ -1,6 +1,7 @@ ## ## Use auto-correlation function to investigate / document / visualize the ## vertical anisotropy within soil profiles +## TODO: keep track of where ACF -> some small value ## ## ## @@ -115,4 +116,10 @@ acfPlot2(x, 'estimated_oc') acfPlot2(x, 'estimated_oc', resample = TRUE) acfPlot(x, 'clay') +acfPlot2(x, 'clay') +acfPlot2(x, 'clay', resample = TRUE) + +acfPlot(x, 'ph_h2o') +acfPlot2(x, 'ph_h2o') +acfPlot2(x, 'ph_h2o', resample = TRUE) diff --git a/misc/sandbox/psc_rank.R b/misc/sandbox/psc_rank.R new file mode 100644 index 000000000..2884e34a9 --- /dev/null +++ b/misc/sandbox/psc_rank.R @@ -0,0 +1,374 @@ + +library(aqp) + + +# PSC ---- +data("soiltexture") +st <- soiltexture$values +st <- st |> + within({ + frags = mean(0:14) |> round(2) + ash = 0 + }) + + +# skeletal +st_sk <- st +st_sk$frags <- mean(35:89) |> round(2) + + +# fragmental +st_fg <- st_sk |> + # subset(texcl == "s") |> + within({ + # sand = sand + 3 + # silt = silt - 1 + # clay = clay - 2 + frags = round(mean(90:100), 2) + }) + + +st <- rbind(st, st_sk, st_fg) + + +# calculate PSC ---- +psc <- texture_to_taxpartsize( + texcl = st$texcl, + clay = st$clay, + sand = st$sand, + fragvoltot = st$frags + ) |> + cbind(st, psc = _) + +psc <- aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = psc, + function(x) round(mean(x, na.rm = TRUE)) + ) |> + dplyr::arrange(frags, -clay, sand) + + +# special classess ---- +clayey <- psc |> + subset(psc %in% c("fine", "very-fine")) |> + within({psc = "clayey"}) |> + aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = _, + function(x) round(mean(x)) + ) + +loamy <- psc |> + subset(psc %in% c("coarse-loamy", "fine-loamy")) |> + within({psc = "loamy"}) |> + aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = _, + function(x) round(mean(x)) + ) + + +## ashy ---- +ashy <- psc |> + subset(sand >= 30 & frags < 35) |> + within({ + psc = "ashy" + tension = mean(0:30) + ash = mean(30:100) + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash, tension) ~ psc, + data = _, + function(x) round(mean(x)) + ) + +# ashy <- psc |> +# subset(psc %in% c("coarse-silty")) |> +# within({ +# psc = "ashy" +# sand = sand + 30 +# silt = silt - 28 +# clay = clay - 2 +# ash = 60 +# }) |> +# aggregate( +# cbind(sand, silt, clay, frags, ash) ~ psc, +# data = _, +# function(x) round(mean(x), 2) +# ) + +ashy_sk <- ashy |> + within({ + psc = "ashy-skeletal" + frags = round(mean(35:89)) + }) + +ashy_pu <- ashy_sk |> + within({ + psc = "ashy-pumiceous" + # sand = sand - 1 + # silt = silt + 0.9 + # clay = clay + 0.1 + frags = round(frags * 2/3) + }) + + +cindery <- psc |> + subset((sand + silt) >= 60 & frags < 35) |> + within({ + psc = "cindery" + # sand = sand - 59 + # silt = silt + 60 + # clay = clay - 1 + ash = 80 + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x)) + ) |> + within({ + frags = round(mean(60:89)) + tension = NA + }) + + +pumiceous <- cindery |> + within({ + psc = "pumiceous" + # sand = sand - 1 + # silt = silt + 0.5 + # clay = clay + 0.5 + frags = round(frags * 2/3) + }) + + +## medial ---- +medial <- psc |> + subset(frags < 35) |> + within({ + psc = "medial" + tension = mean(30:99) + # sand = sand + 30 + # silt = silt - 28 + # clay = clay - 2 + # ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags, tension) ~ psc, + data = _, + function(x) round(mean(x)) + ) +medial <- cbind( + medial[1:5], + ash = NA, + medial[6] +) + + +medial_sk <- medial |> + within({ + psc = "medial-skeletal" + frags = round(mean(35:89)) + }) + +medial_pu <- medial_sk |> + within({ + psc = "medial-pumiceous" + frags = round(frags * 2/3) + }) + + +## hydrous ---- +hydrous <- psc |> + subset(psc %in% c("fine", "very fine")) |> + within({ + psc = "hydrous" + # sand = sand - 18 + # silt = silt + 20 + # clay = clay - 2 + # ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) |> + within({ + ash = NA + tension = 100 + }) + + +hydrous_sk <- hydrous |> + within({ + psc = "hydrous-skeletal" + frags = round(mean(35:89)) + }) + +hydrous_pu <- hydrous_sk |> + within({ + psc = "hydrous-pumiceous" + frags = round(frags * 2/3) + }) + + + +## diatomaceous ---- +diatomaceous <- data.frame( + psc = "diatomaceous", + clay = NA, + sand = NA, + silt = NA, + frags = NA, + ash = NA, + tension = NA, + limnic = 1, + gypsum = 0 + ) + + +## gypseous ---- +co_gypseous <- psc |> + subset(sand >= 50 & frags < 35) |> + within({ + psc = "coarse-gypseous" + # sand = sand + 40 + # silt = silt - 39 + # clay = clay - 1 + # ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = _, + function(x) round(mean(x)) + ) |> + within({ + ash = NA + tension = NA + limnic = 0 + gypsum = mean(40:100) + }) + + +fi_gypseous <- psc |> + subset(sand < 50 & frags < 35) |> + within({ + psc = "fine-gypseous" + # sand = sand + 40 + # silt = silt - 39.8 + # clay = clay - 0.2 + # ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) |> + within({ + ash = NA + tension = NA + limnic = 0 + gypsum = mean(40:100) + }) + + +gypseous_sk <- rbind(fi_gypseous, co_gypseous) |> + within({ + psc = "gypseous-skeletal" + frags = round(mean(35:89), 2) + }) |> + aggregate( + cbind(sand, silt, clay, frags) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) |> + within({ + ash = NA + tension = NA + limnic = 0 + gypsum = mean(40:100) + }) + + +# combine psc ---- +psc_l <- list( + psc = psc, + clayey = clayey, + loamy = loamy, + ashy = ashy, + ashy_sk = ashy_sk, + ashy_pm = ashy_pu, + cindery = cindery, + pumiceous = pumiceous, + medial = medial, + medial_sk = medial_sk, + medial_pu = medial_pu, + hydrous = hydrous, + hydrous_sk = hydrous_sk, + hydrous_pu = hydrous_pu, + diatomaceous = diatomaceous, + fi_gypseous = fi_gypseous, + co_gypseous = co_gypseous, + gypseous_sk = gypseous_sk + ) +psc_l[1:3] <- lapply(psc_l[1:3], function(x) cbind(x, ash = NA, tension = NA, limnic = 0, gypsum = NA)) +psc_l[4:14] <- lapply(psc_l[4:14], function(x) cbind(x, limnic = 0, gypsum = NA)) +psc0 <- do.call("rbind", psc_l) +psc0 <- psc0[order(-psc0$limnic, psc0$frags, -psc0$clay, -psc0$tension, -psc0$gypsum), ] +row.names(psc0) <- NULL +# # rm(list = names(psc_l)[[-1]]) +# +# psc <- psc[order(psc$frags, -psc$limnic, psc$frags, -psc$clay), ] +# row.names(psc) <- NULL +# +# psc1 <- psc0 +# idx <- which(psc1$frags > 35) +# psc1[idx, 2:4] <- apply(psc1[idx, 2:4], 2, function(x) -100 - x* -1) +# psc1 <- psc1[order(psc1$frags, -psc1$clay), ] +# row.names(psc1) <- NULL + +psc1$psc |> dput() +psc1$clay |> dput() + + +# ordination +library(cluster) +library(vegan) +library(compositions) + +psc_acomp <- acomp(psc[2:4]) + +# psc_pc <- psc_acomp |> +# cbind(psc[5]) |> +# princomp() +# plot(psc_pc$scores, type = "n") +# text(psc_pc$scores) + + +d <- psc[-1] |> + daisy() |> + round(2) + +psc_pc <- psc1[c(2, 4, 5)] |> + princomp() +plot(psc_pc$scores, type = "n") +text(psc_pc$scores) + +psc_mds <- metaMDS( + psc0[, c(2, 3, 4, 5)], + k = 1, + distance = "euclidean", + autotransform = FALSE, + wascores = FALSE + ) +plot(psc_mds, type = "t") + +rank <- psc_mds$points[, 1] + + + + + + + diff --git a/misc/sandbox/ragged-profile-bottom.R b/misc/sandbox/ragged-profile-bottom.R index a688c628c..83bba9c5b 100644 --- a/misc/sandbox/ragged-profile-bottom.R +++ b/misc/sandbox/ragged-profile-bottom.R @@ -205,13 +205,13 @@ plotSPC(p[1:10, , .FIRST], cex.names = 0.66, name.style = 'center-center', width plotSPC(p[1:10, , .FIRST], cex.names = 0.66, name.style = 'center-center', width = 0.25, hz.distinctness.offset = 'hzd') -plotSPC(p[1, ], cex.names = 0.66, name.style = 'center-center', width = 0.1, hz.distinctness.offset = 'hzd') +plotSPC(p[1, ], cex.names = 0.66, name.style = 'center-center', width = 0.1, hz.distinctness.offset = 'hzd', max.depth = 145) -plotSPC(p[1, ], cex.names = 0.66, name.style = 'center-center', width = 0.33, hz.distinctness.offset = 'hzd') +plotSPC(p[1, ], cex.names = 0.66, name.style = 'center-center', width = 0.33, hz.distinctness.offset = 'hzd', max.depth = 145) -plotSPC(p[1:5, ], cex.names = 0.66, name.style = 'center-center', width = 0.33, hz.distinctness.offset = 'hzd') +plotSPC(p[1:5, ], cex.names = 0.66, name.style = 'center-center', width = 0.33, hz.distinctness.offset = 'hzd', max.depth = 145) -plotSPC(p[1:10, ], cex.names = 0.66, name.style = 'center-center', width = 0.33, hz.distinctness.offset = 'hzd') +plotSPC(p[1:10, ], cex.names = 0.66, name.style = 'center-center', width = 0.33, hz.distinctness.offset = 'hzd', max.depth = 145) diff --git a/misc/sandbox/sierra-transect-ideas.R b/misc/sandbox/sierra-transect-ideas.R new file mode 100644 index 000000000..06eaefe11 --- /dev/null +++ b/misc/sandbox/sierra-transect-ideas.R @@ -0,0 +1,16 @@ +library(aqp) +data("sierraTransect") + +# horizon boundary viz +sierraTransect$hzd <- hzDistinctnessCodeToOffset(substr(sierraTransect$hz_boundary, 0, 1)) + +# split transects +g <- subset(sierraTransect, transect == 'Granite') + +g.order <- order(g$elev) + +par(mar = c(4, 0, 0, 2.5)) + +plotSPC(g, width = 0.3, name.style = 'center-center', cex.names = 0.9, plot.order = g.order, hz.distinctness.offset = 'hzd') +axis(1, at=1:length(g), labels=g$elev[g.order], line = 0) +mtext(text = 'Elevation (m)', side = 1, font = 2, line = 2.25) diff --git a/misc/sandbox/simulateColor.R b/misc/sandbox/simulateColor.R index 172327c25..ecbaae2d5 100644 --- a/misc/sandbox/simulateColor.R +++ b/misc/sandbox/simulateColor.R @@ -1,9 +1,100 @@ - library(aqp) +library(mvtnorm) + +data(loafercreek, package = 'soilDB') + +# generalize horizon names using REGEX rules +n <- c('Oi', 'A', 'BA','Bt1','Bt2','Bt3','Cr','R') +p <- c('O', '^A$|Ad|Ap|AB','BA$|Bw', + 'Bt1$|^B$','^Bt$|^Bt2$','^Bt3|^Bt4|CBt$|BCt$|2Bt|2CB$|^C$','Cr','R') +loafercreek$genhz <- generalize.hz(loafercreek$hzname, n, p) + +# remove non-matching generalized horizon names +loafercreek$genhz[loafercreek$genhz == 'not-used'] <- NA +loafercreek$genhz <- factor(loafercreek$genhz) + +# all colors +.hvc <- data.frame( + hue = loafercreek$m_hue, + value = loafercreek$m_value, + chroma = loafercreek$m_chroma +) + +p <- list( + list(hvc = .hvc) +) + +# result is a list +m <- simulateColor(method = 'mvnorm', n = 100, parameters = p) + +colorChart(m[[1]]) + +# check original range of hue +# may be narrower than simulation +# may include a few hues outside original range +table(.hvc$hue) + + +# by genhz +h <- horizons(loafercreek) +h <- split(h, h$genhz) + +p <- lapply(h, function(i) { + .res <- data.frame( + hue = i$m_hue, + value = i$m_value, + chroma = i$m_chroma + ) + + return(list(hvc = na.omit(.res))) +}) + +# some genhz have less than required (3) number of rows +sapply(p, sapply, nrow) + +# safely handle parameters without enough data +# 25 simulations of each +m <- simulateColor(method = 'mvnorm', n = 25, parameters = p) + +# invert list -> labeled rows in data.frame +# NULL elements dropped +m <- stack(m) + +# inspect results +colorChart(m$values, m$ind) +colorChart(m$values, m$ind, annotate = TRUE, size = FALSE, chip.cex = 2) + + + +# +# +# cols <- data.frame( +# m = sprintf('%s %s/%s', m$hue, m$value, m$chroma) +# ) +# +# cols$col <- parseMunsell(cols$m) +# +# colorChart(cols$m) +# +# colorChart(cols$m, size = FALSE, chip.cex = 2, annotate = TRUE) +# +# +# previewColors(cols$col, method = 'MDS') + + + + + + + + + + + p <- list( - list(m = '2.5BG 6/6', thresh = 8, hues = c('2.5BG')) + list(m = '10YR 3/4', thresh = 10, hues = c('10YR')) ) s <- simulateColor(method = 'dE00', n = 100, parameters = p) @@ -15,17 +106,6 @@ update(pp, asp = 1) -data(loafercreek, package = 'soilDB') - -# generalize horizon names using REGEX rules -n <- c('Oi', 'A', 'BA','Bt1','Bt2','Bt3','Cr','R') -p <- c('O', '^A$|Ad|Ap|AB','BA$|Bw', - 'Bt1$|^B$','^Bt$|^Bt2$','^Bt3|^Bt4|CBt$|BCt$|2Bt|2CB$|^C$','Cr','R') -loafercreek$genhz <- generalize.hz(loafercreek$hzname, n, p) - -# remove non-matching generalized horizon names -loafercreek$genhz[loafercreek$genhz == 'not-used'] <- NA -loafercreek$genhz <- factor(loafercreek$genhz) cols <- data.frame( @@ -40,8 +120,7 @@ colorChart(cols$m, g = cols$g, annotate = TRUE) colorChart(cols$m, g = cols$g) a <- aggregateColor(loafercreek, 'genhz', k = 8) - - +sharpshootR::aggregateColorPlot(a) ## aggregateColor proportions @@ -84,7 +163,7 @@ zz <- combine(z, s) # cool par(mar = c(0, 0, 1, 0)) -plotSPC(zz, name.style = 'center-center', hz.depths = TRUE, plot.depth.axis = FALSE, width = 0.3) +plotSPC(zz, name.style = 'center-center', hz.depths = TRUE, depth.axis = FALSE, width = 0.3) title('aggregateColor based simulation') @@ -110,7 +189,7 @@ p <- list( 'Bt2' = list(m = '5YR 4/5', thresh = 8, hues = c('5YR', '7.5YR')), 'Bt3' = list(m = '10YR 4/6', thresh = 10, hues = c('10YR', '7.5YR')), 'Cr' = list(m = '2.5G 6/2', thresh = 15, hues = c('2.5G', '2.5GY', '2.5BG')) - ) +) # using dE00 threshold (cols <- simulateColor(method = 'dE00', n = n.sim, parameters = p)) @@ -141,8 +220,16 @@ z <- simulateColor(method = 'dE00', n = n.sim, parameters = p, SPC = z) zz <- combine(z, s) # cool -par(mar = c(0, 0, 1, 0)) -plotSPC(zz, name.style = 'center-center', hz.depths = TRUE, plot.depth.axis = FALSE, width = 0.3) -title('dE00 based simulation') +par(mar = c(0, 0, 0.5, 0)) +plotSPC(zz, name.style = 'center-center', hz.depths = TRUE, depth.axis = FALSE, width = 0.3, lwd = 0.5) +title('dE00 based simulation', line = -2) + +par(mar = c(0, 0, 0.5, 2)) +plotSPC(zz, name.style = 'center-center', width = 0.35, lwd = 0.5, cex.names = 0.7, cex.id = 0.5, max.depth = 100) +title('dE00 based simulation', line = -2) + + + + diff --git a/misc/sandbox/slice-wise-Tukey-HSD.R b/misc/sandbox/slice-wise-Tukey-HSD.R index d3f62a3c2..b095d1ace 100644 --- a/misc/sandbox/slice-wise-Tukey-HSD.R +++ b/misc/sandbox/slice-wise-Tukey-HSD.R @@ -3,11 +3,11 @@ library(aqp) library(soilDB) library(lattice) library(latticeExtra) -library(viridis) +library(tactile) library(grid) # define plotting style -tps <- list(superpose.line=list(col=c('RoyalBlue', 'DarkRed', 'DarkGreen'), lwd=2)) +tps <- tactile.theme(superpose.line=list(col=c('RoyalBlue', 'DarkRed', 'DarkGreen'), lwd=2)) # get multiple series' worth of data # TODO: add code to deal with those series that return 0 records @@ -72,7 +72,7 @@ ck <- list( # standard output from slab() -p.1 <- xyplot(top ~ p.q50 | variable, groups=taxonname, data=HSD$agg, ylab='Depth', +p.1 <- xyplot(top ~ p.q50 | variable, groups=taxonname, data=HSD$agg, ylab='Depth (cm)', xlab='median bounded by 25th and 75th percentiles', lower=HSD$agg$p.q25, upper=HSD$agg$p.q75, ylim=c(105, -5), panel=panel.depth_function, alpha=0.25, sync.colors=TRUE, @@ -94,7 +94,7 @@ p.1 <- xyplot(top ~ p.q50 | variable, groups=taxonname, data=HSD$agg, ylab='Dept # experimental HSD viz p.2 <- segplot( hzn_top ~ lwr + upr, centers = diff, level = p.adj, data = HSD$HSD, - col.regions = viridis, ylim = c(105, -5), + col.regions = hcl.colors, ylim = c(105, -5), xlab = 'HSD', at = col.at, colorkey = ck, @@ -178,7 +178,7 @@ z <- z[idx, vars] dd <- datadist(z) options(datadist="dd") -# GLS: I've used this before to parametrize correlation sturcture +# GLS: I've used this before to parametrize correlation structure (m.gls <- Gls(wmpd ~ rcs(mid) * group, data = z, correlation = corAR1(form = ~ mid | sliceID))) plot(Predict(m.gls)) diff --git a/misc/sandbox/slice-wise-entropy-example.R b/misc/sandbox/slice-wise-entropy-example.R index 6b8038f54..e62c6660c 100644 --- a/misc/sandbox/slice-wise-entropy-example.R +++ b/misc/sandbox/slice-wise-entropy-example.R @@ -1,8 +1,8 @@ library(aqp) library(latticeExtra) -library(plyr) +library(tactile) library(Hmisc) -library(reshape) +library(reshape2) data(sp3) @@ -12,7 +12,7 @@ depths(sp3) <- id ~ top + bottom # http://en.wikipedia.org/wiki/Differential_entropy # http://cran.r-project.org/web/packages/entropy/ -# calculation for continous random vars based on binning / counts +# calculation for continuous random vars based on binning / counts # http://cran.r-project.org/web/packages/entropy/entropy.pdf ## this isn't correct, and barfs when there is < 90% data available @@ -154,14 +154,16 @@ wtd.sum.qcd <- function(i){ # compute some "information" metrics -a <- slab(sp3, ~ clay + A + cec + ph, slab.fun=mean.and.sd, slab.structure=0:100) -a.1 <- slab(sp3, ~ clay + A + cec + ph, slab.fun=f.entropy, slab.structure=0:100) -a.2 <- slab(sp3, ~ clay + A + cec + ph, slab.fun=f.sig.to.noise, slab.structure=0:100) -a.3 <- slab(sp3, ~ clay + A + cec + ph, slab.fun=f.qcd, slab.structure=0:100) +a <- slab(sp3, ~ clay + A + cec + ph, slab.fun = mean.and.sd, slab.structure = 0:100) +a.1 <- slab(sp3, ~ clay + A + cec + ph, slab.fun = f.entropy, slab.structure = 0:100) +a.2 <- slab(sp3, ~ clay + A + cec + ph, slab.fun = f.sig.to.noise, slab.structure = 0:100) +a.3 <- slab(sp3, ~ clay + A + cec + ph, slab.fun = f.qcd, slab.structure = 0:100) # combine -g <- make.groups(summary=a, entropy=a.1, sig.to.noise=a.2, qcd=a.3) -g$which <- factor(g$which, labels=c('Mean +/- 1SD', 'psuedo-Entropy', 'Signal : Noise', 'QCD')) +g <- make.groups(summary = a, entropy = a.1, sig.to.noise = a.2, qcd = a.3) +g$which <- factor(g$which, labels = c('Mean +/- 1SD', 'psuedo-Entropy', 'Signal : Noise', 'QCD')) + +.tps <- tactile.theme(superpose.line=list(lwd=2, col=c('RoyalBlue', 'Orange2'))) p <- xyplot( top ~ value | which + variable, data=g, @@ -170,7 +172,7 @@ p <- xyplot( ylab='Depth (cm)', xlab='', ylim=c(100,-5), layout=c(5,3), scales=list(x=list(relation='free')), - par.settings=list(superpose.line=list(lwd=2, col=c('RoyalBlue', 'Orange2'))), + par.settings = .tps, panel=panel.depth_function, prepanel=prepanel.depth_function, auto.key=list(columns=2, lines=TRUE, points=FALSE) @@ -181,20 +183,21 @@ useOuterStrips(p, strip=strip.custom(bg=grey(0.85)), strip.left = strip.custom(h ## a "no-information QCD" must be computed from the raw data, by depth-slice -s <- slice(sp3, 0:100 ~ clay + A + cec + ph, just.the.data = TRUE) +s <- dice(sp3, fm = 0:100 ~ clay + A + cec + ph, SPC = FALSE) s.long <- melt(s, id.vars = c('top', 'bottom'), measure.vars = c('clay', 'A', 'cec', 'ph')) -qcd.ni <- ddply(s.long, c('variable'), no.information.qcd) + +qcd.ni <- lapply(split(s.long, s.long$variable), no.information.qcd) ## compute weighted mean and weighted sum QCD by variable ## note that these must be standardized by slice-wise "no-information" QCD -wm.qcd <- ddply(a.3, 'variable', .fun=wtd.mean.qcd) -ws.qcd <- ddply(a.3, 'variable', .fun=wtd.sum.qcd) - -### does this make sense? -# join QCD summaries to "no-information" baseline -ss <- join(join(wm.qcd, ws.qcd), qcd.ni) -transform(ss, mean.qcd=wt.mean.qcd / mean.ni.qcd, sum.qcd=wt.sum.qcd / sum.ni.qcd) - +# wm.qcd <- ddply(a.3, 'variable', .fun=wtd.mean.qcd) +# ws.qcd <- ddply(a.3, 'variable', .fun=wtd.sum.qcd) +# +# ### does this make sense? +# # join QCD summaries to "no-information" baseline +# ss <- join(join(wm.qcd, ws.qcd), qcd.ni) +# transform(ss, mean.qcd=wt.mean.qcd / mean.ni.qcd, sum.qcd=wt.sum.qcd / sum.ni.qcd) +# diff --git a/misc/sandbox/warp-examples-testing.R b/misc/sandbox/warp-examples-testing.R index 45229a1ec..99f55b26b 100644 --- a/misc/sandbox/warp-examples-testing.R +++ b/misc/sandbox/warp-examples-testing.R @@ -100,14 +100,40 @@ plotSPC(x, name.style = 'center-center', cex.names = 0.8, width = 0.2, max.depth arrows(x0 = 1 + 0.25, y0 = .y1, x1 = 2 - 0.25, y1 = .y2, len = 0.1, col = 2) - +# symbolize warping factor with color o$fact <- c(1, 1, 1, 1, 1, 1, 1, 1) oo$fact <- c(1.8, 1.3, 0.6, 0.75, 0.8, 1, 1, 1) x <- combine(o, oo) par(mar = c(1, 0, 3 , 1)) -plotSPC(x, name.style = 'center-center', cex.names = 0.8, width = 0.2, max.depth = 200, depth.axis = FALSE, hz.depths = TRUE, color = 'fact') +plotSPC(x, name.style = 'center-center', cex.names = 0.8, width = 0.2, max.depth = 200, depth.axis = FALSE, hz.depths = TRUE, color = 'fact', col.label = 'Horizon Warp Factor') arrows(x0 = 1 + 0.33, y0 = .y1, x1 = 2 - 0.22, y1 = .y2, len = 0.1, col = 'black') +## +wf <- c(0.5, 0.8, 0.9, 0.95, 1, 1, 1, 3) + +oo <- warpHorizons(o, fact = wf) +x <- combine(o, oo) + +.y1 <- x[1, , .TOP] +.y2 <- x[2, , .TOP] + +par(mar = c(1, 0, 0 , 2)) +plotSPC(x, name.style = 'center-center', cex.names = 0.8, width = 0.2, max.depth = 200, depth.axis = list(line = -3)) +arrows(x0 = 1 + 0.25, y0 = .y1, x1 = 2 - 0.25, y1 = .y2, len = 0.1, col = 2) + + +# symbolize warping factor with color +o$fact <- c(1, 1, 1, 1, 1, 1, 1, 1) +oo$fact <- wf +x <- combine(o, oo) + +par(mar = c(1, 0, 3 , 1)) +plotSPC(x, name.style = 'center-center', cex.names = 0.9, width = 0.22, max.depth = 200, depth.axis = FALSE, hz.depths = TRUE, color = 'fact', col.label = 'Horizon Warp Factor') +arrows(x0 = 1 + 0.38, y0 = .y1, x1 = 2 - 0.28, y1 = .y2, len = 0.1, col = 'black') + + + + diff --git a/misc/utils/Munsell/interpolate-spectra.R b/misc/utils/Munsell/interpolate-spectra.R index cb76d5daa..c55fe092e 100644 --- a/misc/utils/Munsell/interpolate-spectra.R +++ b/misc/utils/Munsell/interpolate-spectra.R @@ -1,12 +1,30 @@ +## +## +## + + + +## TODO: clamp to original range of Munsell chroma and value +## TODO: coordinate with `prepare-munsell-LUT.R` + + library(lattice) library(tactile) -library(pbapply) +library(purrr) library(reshape2) +source('local-functions.R') + # load simplified spectra m.rel <- readRDS('simplified-Munsell-spectra.rds') -## investigate slices -- can interpolate reflectance vs chroma (by wavelengths) for odd chroma +# review original range +range(m.rel$reflectance) +min.reflectance <- min(m.rel$reflectance) + +hist(m.rel$reflectance, breaks = 50) + +## interpolate spectra for odd Munsell chroma idx <- which(m.rel$hue %in% c('7.5YR') & m.rel$value == 3) s <- m.rel[idx, ] @@ -21,75 +39,8 @@ xyplot(reflectance ~ chroma | factor(wavelength), data=s, # split by hue/value/wavelength m <- split(m.rel, list(m.rel$hue, m.rel$value, m.rel$wavelength)) -# interpolation of odd chroma -interpolateOddChromaSpectra <- function(i) { - - # 0-row input - if(nrow(i) < 1) - return(NULL) - - # chroma stats - u.chroma <- unique(i$chroma) - r.chroma <- range(u.chroma) - n.chroma <- length(u.chroma) - - # reflectance stats - r.reflectance <- range(i$reflectance) - - # sequence of candidate chroma - s <- seq(from = r.chroma[1], to = r.chroma[2], by = 1) - s.chroma <- setdiff(s, u.chroma) - - # short circuit: single chroma, interpolation impossible - if(n.chroma < 2) - return(NULL) - - # short circuit: 0 candidates for interpolation - if(length(s.chroma) < 1) - return(NULL) - - - # setup interpolation function: natural splines - # fit is exact at training points - af <- splinefun(i$chroma, i$reflectance, method = 'natural') - - # check: fit should be exact at points - if(sum(af(i$chroma) - i$reflectance) > 0.001){ - message('spline not fitting at training data!') - } - - # interpolate candidate chroma - s.reflectance <- af(s.chroma) - - # # check for over / undershoots - # if( ! (s.reflectance < r.reflectance[1] | s.reflectance > r.reflectance[2])){ - # message('spline exceeds original range!') - # } - - # re-assemble into original format - res <- data.frame( - munsell = sprintf("%s %s/%s", i$hue[1], i$value[1], s.chroma), - hue = i$hue[1], - value = i$value[1], - chroma = s.chroma, - wavelength = i$wavelength[1], - reflectance = s.reflectance, - stringsAsFactors = FALSE - ) - - - # debugging: graphical check - # OK - # plot(reflectance ~ chroma, data = i ) - # lines(seq(r.chroma[1], r.chroma[2], by = 0.1), af(seq(r.chroma[1], r.chroma[2], by = 0.1)), col = 'red') - # points(s.chroma, s.reflectance, pch = 15) - - return(res) - -} - # do interpolation -mm <- pblapply(m, interpolateOddChromaSpectra) +mm <- map(m, .f = interpolateOddChromaSpectra, .progress = TRUE) # combine mm <- do.call('rbind', mm) @@ -100,7 +51,16 @@ m.final <- m.final[order(m.final$hue, m.final$value, m.final$chroma), ] # graphical check -idx <- which(m.final$hue %in% c('7.5YR') & m.final$value == 5) +idx <- which(m.final$hue %in% c('7.5YR') & m.final$value == 3) +s <- m.final[idx, ] + +xyplot(reflectance ~ chroma | factor(wavelength), data=s, + type='b', as.table=TRUE, + scales = list(y = list(tick.number = 10)), + par.settings = tactile.theme() +) + +idx <- which(m.final$hue %in% c('2.5YR') & m.final$value == 4) s <- m.final[idx, ] xyplot(reflectance ~ chroma | factor(wavelength), data=s, @@ -110,8 +70,10 @@ xyplot(reflectance ~ chroma | factor(wavelength), data=s, ) + # check for reflectance <= 0 -m.final[m.final$reflectance <= 0, ] +# 6 rows +nrow(m.final[m.final$reflectance <= 0, ]) # hmm idx <- which(m.final$hue %in% c('2.5R') & m.final$value == 2) @@ -128,12 +90,22 @@ xyplot(reflectance ~ chroma | factor(wavelength), groups = reflectance <= 0, dat idx <- which(m.final$reflectance <= 0) m.final[idx, ] -# replace with minimum reflectance, ignoring these values -m.final$reflectance[idx] <- min(m.final$reflectance[-idx]) +# replace with original minimum reflectance, ignoring these values +m.final$reflectance[idx] <- min.reflectance + +xyplot(reflectance ~ chroma | factor(wavelength), groups = reflectance <= 0, + data = m.final, + subset = hue == '2.5R' & value == 2, + type='b', as.table=TRUE, + scales = list(y = list(tick.number = 10)), + auto.key=list(lines=FALSE, points=TRUE, cex=1, space='top'), + par.settings = tactile.theme() +) + ## check: OK -s <- subset(m.final, subset = hue == '2.5YR' & value == 4 & chroma %in% 2:4) +s <- subset(m.final, subset = hue == '5YR' & value == 4 & chroma %in% 2:4) xyplot(reflectance ~ wavelength, data = s, groups = munsell, type='b', @@ -143,59 +115,25 @@ xyplot(reflectance ~ wavelength, data = s, ) - - -## interpolate 2.5 value - -# just 2/3 value -m.sub <- subset(m.final, subset = value %in% 2:3) - -head(m.sub) - -# check -s <- subset(m.sub, subset = hue == '2.5YR' & chroma == 3) +s <- subset(m.final, subset = hue == '2.5Y' & value == 4 & chroma %in% 2:4) xyplot(reflectance ~ wavelength, data = s, groups = munsell, type='b', scales = list(y = list(tick.number = 10)), - auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 2), + auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 3), par.settings = tactile.theme() ) + +## interpolate spectra for select half-chip Munsell values + # split by hue/chroma/wavelength -m <- split(m.sub, list(m.sub$hue, m.sub$chroma, m.sub$wavelength)) - - -interpolateValueSpectra <- function(i) { - - # 0 or 1 row input: no interpolation possible - if(nrow(i) < 2) - return(NULL) - - # linear interpolation between value 2--3 - a.fun <- approxfun(i$value, i$reflectance) - - # single value for now - v.target <- 2.5 - - # re-assemble into original format - res <- data.frame( - munsell = sprintf("%s %s/%s", i$hue[1], v.target, i$chroma[1]), - hue = i$hue[1], - value = v.target, - chroma = i$chroma[1], - wavelength = i$wavelength[1], - reflectance = a.fun(v.target), - stringsAsFactors = FALSE - ) - - return(res) -} +m <- split(m.final, list(m.final$hue, m.final$chroma, m.final$wavelength)) # do interpolation -mm <- pblapply(m, interpolateValueSpectra) +mm <- map(m, .f = interpolateValueSpectra, .progress = TRUE) # combine mm <- do.call('rbind', mm) @@ -205,19 +143,60 @@ mm <- do.call('rbind', mm) m.final <- rbind(m.final, mm) m.final <- m.final[order(m.final$hue, m.final$value, m.final$chroma), ] - # check: OK str(m.final) -s <- subset(m.final, subset = hue == '2.5YR' & chroma == 3) + +# check for reflectance <= 0 +# 3403 rows, all very close to 0 +# most of these are very low value + low chroma | low value + high chroma +nrow(m.final[m.final$reflectance <= 0, ]) + +# hmm +idx <- which(m.final$munsell == '7.5YR 2.5/14') +s <- m.final[idx, ] + +xyplot(reflectance ~ chroma | factor(wavelength), groups = reflectance <= 0, data=s, + type='b', as.table=TRUE, + scales = list(y = list(tick.number = 10)), + auto.key=list(lines=FALSE, points=TRUE, cex=1, space='top'), + par.settings = tactile.theme() +) + +# probably spline undershoots +idx <- which(m.final$reflectance <= 0) + +# replace with minimum reflectance, ignoring these values +m.final$reflectance[idx] <- min.reflectance + + + + +s <- subset(m.final, subset = hue == '10YR' & chroma == 4 & value %in% c(2, 2.5, 3, 4)) + +xyplot(reflectance ~ wavelength, data = s, + groups = munsell, type='b', + scales = list(y = list(tick.number = 10)), + auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 3), + par.settings = tactile.theme() +) + +s <- subset(m.final, subset = hue == '2.5Y' & chroma == 4 & value %in% c(7, 8, 8.5, 9, 9.5, 10)) xyplot(reflectance ~ wavelength, data = s, groups = munsell, type='b', scales = list(y = list(tick.number = 10)), - auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 2), + auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 3), par.settings = tactile.theme() ) +xyplot(reflectance ~ value | wavelength, data = s, + type='b', + as.table = TRUE, + scales = list(alternating = 3, y = list(tick.number = 10)), + auto.key=list(lines=TRUE, points=FALSE, cex=1, space='top', columns = 3), + par.settings = tactile.theme() +) @@ -238,6 +217,11 @@ save(munsell.spectra, file = '../../../data/munsell.spectra.rda', compress = 'xz save(munsell.spectra.wide, file = '../../../data/munsell.spectra.wide.rda', compress = 'xz') # cleanup -unlink(c('interpolated-Munsell-spectra-wide.rds', 'interpolated-Munsell-spectra.rds', 'simplified-Munsell-spectra.rds')) +unlink( + c('interpolated-Munsell-spectra-wide.rds', + 'interpolated-Munsell-spectra.rds', + 'simplified-Munsell-spectra.rds' + ) +) diff --git a/misc/utils/Munsell/investigate-spectral-interpolation-errors.R b/misc/utils/Munsell/investigate-spectral-interpolation-errors.R new file mode 100644 index 000000000..473030fe7 --- /dev/null +++ b/misc/utils/Munsell/investigate-spectral-interpolation-errors.R @@ -0,0 +1,42 @@ +library(purrr) + +data("munsell.spectra.wide") + +nm <- names(munsell.spectra.wide)[-1] +s <- sample(nm, size = 100) + +z <- do.call( + 'rbind', + map(s, .progress = TRUE, .f = function(i) { + spec2Munsell(munsell.spectra.wide[, i]) + }) +) + +z$m <- sprintf("%s %s/%s", z$hue, z$value, z$chroma) + +# compare +cc <- colorContrast( + m1 = s, + m2 = z$m +) + +hist(cc$dE00, breaks = 25) + +## TODO: investigate these +x <- cc[order(cc$dE00, decreasing = TRUE)[1:10], ] + +x + + +# 10G 9.5/10 +.m <- '5YR 2.5/10' +plot(munsell.spectra.wide[, 1], munsell.spectra.wide[, .m], type = 'b', las = 1, main = .m, ylim = c(0, 1.2)) +spec2Munsell(munsell.spectra.wide[, .m]) + + +# 10G 9.5/10 +.m <- '10G 9.5/10' +plot(munsell.spectra.wide[, 1], munsell.spectra.wide[, .m], type = 'b', las = 1, main = .m, ylim = c(0, 1.2)) +lines(munsell.spectra.wide[, 1], munsell.spectra.wide[, '10G 6/10'], type = 'b', col = 2) +lines(munsell.spectra.wide[, 1], munsell.spectra.wide[, '10G 8/6'], type = 'b', col = 2) +spec2Munsell(munsell.spectra.wide[, .m]) diff --git a/misc/utils/Munsell/local-functions.R b/misc/utils/Munsell/local-functions.R index 9f43549ed..1d98e1287 100644 --- a/misc/utils/Munsell/local-functions.R +++ b/misc/utils/Munsell/local-functions.R @@ -1,30 +1,128 @@ + + +## TODO: clamp to original range of Munsell chroma + +# interpolation of odd chroma +interpolateOddChromaSpectra <- function(i) { + + # 0-row input + if(nrow(i) < 1) { + return(NULL) + } + + # chroma stats + u.chroma <- unique(i$chroma) + r.chroma <- range(u.chroma) + n.chroma <- length(u.chroma) + + # reflectance stats + r.reflectance <- range(i$reflectance) + + # sequence of candidate chroma + s <- seq(from = r.chroma[1], to = r.chroma[2], by = 1) + s.chroma <- setdiff(s, u.chroma) + + # short circuit: single chroma, interpolation impossible + if(n.chroma < 2) + return(NULL) + + # short circuit: 0 candidates for interpolation + if(length(s.chroma) < 1) + return(NULL) + + + # setup interpolation function: natural splines + # fit is exact at training points + sf <- splinefun(i$chroma, i$reflectance, method = 'natural') + + # check: fit should be exact at points + if(sum(sf(i$chroma) - i$reflectance) > 0.001){ + message('spline not fitting at training data!') + } + + # interpolate candidate chroma + s.reflectance <- sf(s.chroma) + + # re-assemble into original format + res <- data.frame( + munsell = sprintf("%s %s/%s", i$hue[1], i$value[1], s.chroma), + hue = i$hue[1], + value = i$value[1], + chroma = s.chroma, + wavelength = i$wavelength[1], + reflectance = s.reflectance, + stringsAsFactors = FALSE + ) + + + # debugging: graphical check + # OK + # plot(reflectance ~ chroma, data = i ) + # lines(seq(r.chroma[1], r.chroma[2], by = 0.1), af(seq(r.chroma[1], r.chroma[2], by = 0.1)), col = 'red') + # points(s.chroma, s.reflectance, pch = 15) + + return(res) + +} + + +interpolateValueSpectra <- function(i) { + + # 0 or 1 row input: no interpolation possible + if(nrow(i) < 2) + return(NULL) + + # setup interpolation function: natural splines + # fit is exact at training points + a.fun <- splinefun(i$value, i$reflectance, method = 'natural') + + # new Munsell values + v.target <- c(2.5, 8.5, 9.5) + + # re-assemble into original format + res <- data.frame( + munsell = sprintf("%s %s/%s", i$hue[1], v.target, i$chroma[1]), + hue = i$hue[1], + value = v.target, + chroma = i$chroma[1], + wavelength = i$wavelength[1], + reflectance = a.fun(v.target), + stringsAsFactors = FALSE + ) + + return(res) +} + + + + + # 2022-03-29 +# interpolate odd chroma from Munsell renotation data +# m.i: subset renotation data.frame, for a single hue/value interpolateChroma <- function(m.i) { - # interpolation over S(y ~ C) and S(x ~ C) - s.x <- splinefun(m.i$C, m.i$x) - s.y <- splinefun(m.i$C, m.i$y) + # spline interpolation over S(y ~ C) and S(x ~ C) + # fit is exact at training points + s.x <- splinefun(m.i$C, m.i$x, method = 'natural') + s.y <- splinefun(m.i$C, m.i$y, method = 'natural') # make predictions along range of 1 -> max(C) # but only where we are missing data - C.original <- m.i$C - C.full <- seq(from = 1, to = max(m.i$C), by = 1) - C.new <- setdiff(C.full, C.original) - - # eval spline functions along missing points - p.x <- s.x(C.new) - p.y <- s.y(C.new) + .original <- m.i$C + .full <- seq(from = 1, to = max(m.i$C), by = 1) + .new <- setdiff(.full, .original) # combine interpolated values into data.frame # H, V, Y are constant m.new <- data.frame( H = m.i$H[1], V = m.i$V[1], - C = C.new, - x = p.x, - y = p.y, - Y= m.i$Y[1] + C = .new, + x = s.x(.new), + y = s.y(.new), + Y = m.i$Y[1] ) # stack and re-order along C values @@ -38,6 +136,52 @@ interpolateChroma <- function(m.i) { } +# 2024-09-26 +# re-write of interpolateValue() -> now safely interpolates all 0.5 values +# m.i: data.frame of Munsell renotation data, for a single hue and chroma +interpolateValue2 <- function(m.i) { + + # can only proceed with >=2 rows + # some combinations of hue, value, chroma have 1 row. + # there will be other combinations created by split() with 0 rows + if(nrow(m.i) < 2) { + return(NULL) + } + + # spline interpolation ~ munsell value + # fit is exact at training points + # x ~ V + s.1 <- splinefun(m.i$V, m.i$x, method = 'natural') + # y ~ V + s.2 <- splinefun(m.i$V, m.i$y, method = 'natural') + # Y ~ V + s.3 <- splinefun(m.i$V, m.i$Y, method = 'natural') + + # new Munsell values for which interpolated xyY coordinates are required + # limited to the range of available value at this hue/chroma combination + new.V <- seq(from = min(m.i$V) + 0.5, to = max(m.i$V) - 0.5, by = 1) + + # TODO: coordinate with interpolation of spectra + + # combine interpolated values into data.frame + # H, C are constant + m.new <- data.frame( + H = m.i$H[1], + V = new.V, + C = m.i$C[1], + p1 = s.1(new.V), + p2 = s.2(new.V), + p3 = s.3(new.V) + ) + + names(m.new) <- c('H', 'V', 'C', 'x', 'y', 'Y') + + # only return new rows + return(m.new) +} + + +## NOTE: this can only interpolate between two integer values # 2022-03-29 # for now only interpolating 2.5 value # usually interpolating xyY, @@ -72,15 +216,6 @@ interpolateValue <- function(m.i, new.V = 2.5, vars = c('x', 'y', 'Y')) { -# -# # compute midpoints between a sequence of points: -# mdpts <- function(x) -# { -# m <- ( x[1:length(x)-1] + x[2:length(x)] ) / 2 -# m -# } -# - # @@ -123,7 +258,11 @@ xyY2XYZ <- function(xyY.data) { ## this has been revised as of Jan 2008 ## new version: - M_adapt_C_to_D65 <- matrix(c(0.990448, -0.012371, -0.003564, -0.007168, 1.015594, 0.006770, -0.011615, -0.002928, 0.918157), ncol=3, byrow=TRUE) + M_adapt_C_to_D65 <- matrix( + c(0.990448, -0.012371, -0.003564, -0.007168, 1.015594, 0.006770, -0.011615, -0.002928, 0.918157), + ncol = 3, + byrow = TRUE + ) # @@ -140,8 +279,7 @@ xyY2XYZ <- function(xyY.data) { ## ## updated August 2009 ## -XYZ2rgb <- function(mun_XYZ_D65) - { +XYZ2rgb <- function(mun_XYZ_D65) { # @@ -161,7 +299,11 @@ XYZ2rgb <- function(mun_XYZ_D65) # http://www.brucelindbloom.com/Eqn_RGB_XYZ_Matrix.html # # sRGB profile: - M_XYZ_to_sRGB_D65 <- matrix(c(3.24071, -0.969258, 0.0556352, -1.53726, 1.87599, -0.203996, -0.498571, 0.0415557, 1.05707), ncol=3, byrow=TRUE) + M_XYZ_to_sRGB_D65 <- matrix( + c(3.24071, -0.969258, 0.0556352, -1.53726, 1.87599, -0.203996, -0.498571, 0.0415557, 1.05707), + ncol = 3, + byrow = TRUE + ) @@ -196,7 +338,7 @@ XYZ2rgb <- function(mun_XYZ_D65) B_clip <- ifelse(B > 1, 1, B_clip) - return(data.frame(R=R_clip, G=G_clip, B=B_clip)) + return(data.frame(R = R_clip, G = G_clip, B = B_clip)) } diff --git a/misc/utils/Munsell/main.R b/misc/utils/Munsell/main.R index 4ab53c6bb..56f3c3005 100644 --- a/misc/utils/Munsell/main.R +++ b/misc/utils/Munsell/main.R @@ -1,9 +1,11 @@ ## Code / Data related to preparation of Munsell color interpretation in aqp -## 2022-03-29 +## 2024-10-03 ## D.E. Beaudette, A.G. Brown # make Munsell and related LUT -# add neutral chips +# + neutral chips +# + odd chroma +# + 0.5 value # xyY [C] -> XYZ [D65] -> sRGB -> CIELAB source('prepare-munsell-LUT.R') @@ -17,8 +19,14 @@ source('traditional-names.R') # prepare a simplified spectral library of Munsell color chips source('prepare-simplfied-spectra-library.R') -# interpolate odd chroma and 2.5 value spectra +# interpolate odd chroma and select 1/2 chip value spectra source('interpolate-spectra.R') +# TODO: investigate poor agreement between +# Munsell reference and predicted CIELAB -> Munsell conversion +# these are probably extrapolation artifacts +source('investigate-spectral-interpolation-errors.R') + + # create Munsell hue position data source('make-munsellHuePosition.R') diff --git a/misc/utils/Munsell/munsell-LUT-2024-09-25.rds b/misc/utils/Munsell/munsell-LUT-2024-09-25.rds new file mode 100644 index 000000000..6559ccfbc Binary files /dev/null and b/misc/utils/Munsell/munsell-LUT-2024-09-25.rds differ diff --git a/misc/utils/Munsell/prepare-munsell-LUT.R b/misc/utils/Munsell/prepare-munsell-LUT.R index dff23dbfc..00a20ad87 100644 --- a/misc/utils/Munsell/prepare-munsell-LUT.R +++ b/misc/utils/Munsell/prepare-munsell-LUT.R @@ -1,24 +1,46 @@ +## Prepare `munsell` LUT from Renotation Database +## D.E. Beaudette +## 2024-10-03 +## +## Originally based on code from ~2006 as part of the Pedlogic project. +## + library(latticeExtra) library(tactile) library(grDevices) library(scales) -library(pbapply) +library(purrr) library(aqp) + +# starting from aqp base directory +setwd('misc/utils/Munsell') source('local-functions.R') -# munsell data comes with a lookup table in xyY colorspace -# url: http://www.cis.rit.edu/mcsl/online/munsell.php - -# Munsell chroma, CIE x, y, and Y. The chromaticity coordinates were calculated using illuminant C and the CIE 1931 2 degree observer. +## +## Notes / Ideas: +## +## * univariate interpolation of odd-chroma and 0.5-value chips seems to work well +## * consider retaining values 0.2-0.8 for improved interpolation +## * is multivariate interpolation necessary? (I doubt it) +## + + + +## munsell data comes with a lookup table in xyY colorspace +## url: http://www.cis.rit.edu/mcsl/online/munsell.php + +## Munsell chroma, CIE x, y, and Y. +## The chromaticity coordinates were calculated using +## illuminant C and the CIE 1931 2 degree observer. m <- read.table("munsell-all.dat.gz", header=TRUE) ## rescale Y # note: the data from the Munsell group contains Y values # that are in the range of approx: 0-100 - + # these need to be rescaled to the range of 0-1, # but not using the existing min/max values # instead, set the max Y value at 100 @@ -27,73 +49,364 @@ m$Y <- pmin(m$Y, 100) # rescale Y to [0,1] m$Y <- rescale(m$Y, to = c(0, 1)) -## remove vale < 1 --> 765 records +## remove value < 1 --> 765 records m <- subset(m, V >= 1) + + + +## ## interpolate odd chroma chips +## + # also interpolate backwards to C == 1 -m.split <- split(m, list(m$H, m$V)) +z <- split(m, list(m$H, m$V)) # this combines original + interpolated values -m.new.chroma <- pblapply(m.split, interpolateChroma) +m.new.chroma <- map(z, .f = interpolateChroma, .progress = TRUE) m.new.chroma <- do.call('rbind', m.new.chroma) +# 8460 rows +nrow(m.new.chroma) + ## graphical check -p.1 <- xyplot(x ~ C | factor(V), groups = H, data = m, subset = H %in% c('2.5YR', '2.5Y'), type = 'p', par.settings = tactile.theme(), as.table = TRUE, scales = list(alternating = 1), cex = 1.25, xlim = c(-1, 25)) +.cols <- hcl.colors(length(unique(m$V))) + +p1 <- xyplot( + x ~ C | factor(H), + groups = V, + data = m, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'p', + par.settings = tactile.theme(superpose.symbol = list(col = .cols)), + as.table = TRUE, + scales = list(alternating = 1), + cex = 1.25, + xlim = c(-1, 25), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) + +p2 <- xyplot( + x ~ C | factor(H), + groups = V, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'p', + par.settings = tactile.theme(superpose.symbol = list(col = .cols)), + as.table = TRUE, + scales = list(alternating = 1), + pch = 16, + cex = 0.5, + xlim = c(-1, 25), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) + +# ok +update(p1 + p2, auto.key = list(title = 'V')) + + +p1 <- xyplot( + y ~ C | factor(H), + groups = V, + data = m, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'p', + par.settings = tactile.theme(superpose.symbol = list(col = .cols)), + as.table = TRUE, + scales = list(alternating = 1), + cex = 1.25, + xlim = c(-1, 25), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) + +p2 <- xyplot( + y ~ C | factor(H), + groups = V, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'p', + par.settings = tactile.theme(superpose.symbol = list(col = .cols)), + as.table = TRUE, + scales = list(alternating = 1), + pch = 16, + cex = 0.5, + xlim = c(-1, 25), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) + +# ok +update(p1 + p2, auto.key = list(title = 'V')) + + + +# original +p1 <- xyplot( + x ~ C | factor(V), + groups = factor(H, levels = c('2.5Y', '2.5YR', '2.5R')), + data = m, + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 1.25, + xlim = c(-1, 25) +) + +# interpolated +p2 <- xyplot( + x ~ C | factor(V), + groups = factor(H, levels = c('2.5Y', '2.5YR', '2.5R')), + data = m.new.chroma, + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 0.5, + pch = 16 +) + +# good +update(p1 + p2, auto.key = list(title = 'H')) + + +# original +p1 <- xyplot( + x ~ C | factor(V), + groups = factor(H, levels = c('2.5Y', '2.5YR', '2.5G')), + data = m, + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 1.25, + xlim = c(-1, 25) +) + +# interpolated +p2 <- xyplot( + x ~ C | factor(V), + groups = factor(H, levels = c('2.5Y', '2.5YR', '2.5G')), + data = m.new.chroma, + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 0.5, + pch = 16 +) + +# good +update(p1 + p2, auto.key = list(title = 'H')) + + + -p.2 <- xyplot(x ~ C | factor(V), groups = H, data = m.new.chroma, subset = H %in% c('2.5YR', '2.5Y'), type = 'p', par.settings = tactile.theme(), as.table = TRUE, scales = list(alternating = 1), cex = 0.5, pch = 16) -p.1 + p.2 +## verify odd chroma frequencies +# good +table(m.new.chroma$C) -p.1 <- xyplot(y ~ C | factor(V), groups = H, data = m, subset = H %in% c('2.5YR', '2.5Y'), type = 'p', par.settings = tactile.theme(), as.table = TRUE, scales = list(alternating = 1), cex = 1.25, xlim = c(-1, 25)) -p.2 <- xyplot(y ~ C | factor(V), groups = H, data = m.new.chroma, subset = H %in% c('2.5YR', '2.5Y'), type = 'p', par.settings = tactile.theme(), as.table = TRUE, scales = list(alternating = 1), cex = 0.5, pch = 16) +## TODO: +# * do we need multivariate interpolation? -p.1 + p.2 +.n <- length(unique(m.new.chroma$C[m.new.chroma$H %in% c('2.5Y', '2.5YR', '2.5R')])) +.cols <- hcl.colors(n = .n, palette = 'blues3') +xyplot( + x ~ V | factor(H), + groups = C, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'l', + par.settings = tactile.theme(superpose.line = list(col = .cols, lwd = 2)), + as.table = TRUE, + scales = list(alternating = 1), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) +xyplot( + y ~ V | factor(H), + groups = C, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'l', + par.settings = tactile.theme(superpose.line = list(col = .cols, lwd = 2)), + as.table = TRUE, + scales = list(alternating = 1), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) -summary(m.new.chroma) +xyplot( + Y ~ V | factor(H), + groups = C, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'l', + par.settings = tactile.theme(superpose.line = list(col = .cols)), + as.table = TRUE, + scales = list(alternating = 1), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) -## interpolate 2.5 values -# only need 2 value-slices -m.sub <- subset(m.new.chroma, V %in% c(2, 3)) -m.sub <- split(m.sub, list(m.sub$H, m.sub$C)) -# note: some combinations are missing values 2 AND 3 -table(sapply(m.sub, nrow)) -# 0 1 2 -# 1102 140 718 -# only process those with 2 records -idx <- which(sapply(m.sub, nrow) == 2) -m.sub <- m.sub[idx] -m.2.5.values <- pblapply(m.sub, interpolateValue) -m.2.5.values <- do.call('rbind', m.2.5.values) +## +## interpolate all half-value chips +## + +z <- split(m.new.chroma, list(m.new.chroma$H, m.new.chroma$C)) +zz <- map(z, .f = interpolateValue2, .progress = TRUE) -nrow(m.2.5.values) -head(m.2.5.values) +# remove NULLs +# these are H/C combinations where interpolation is not possible +idx <- which(!sapply(zz, is.null)) +zz <- zz[idx] -## stack interpolated 2.5 values -m.new.chroma <- rbind(m.new.chroma, m.2.5.values) +zz <- do.call('rbind', zz) +nrow(zz) + +# stack interpolated values +m.new.chroma <- rbind(m.new.chroma, zz) # sort m.new.chroma <- m.new.chroma[order(m.new.chroma$H, m.new.chroma$V, m.new.chroma$C), ] -str(m.new.chroma) +# 15700 +nrow(m.new.chroma) + + +## for backwards compatibility, retain specific Munsell values +table(m.new.chroma$V) + +m.new.chroma <- subset( + m.new.chroma, + subset = V %in% c(1, 2, 2.5, 3, 4, 5, 6, 7, 8, 8.5, 9, 9.5, 10) +) + +# check: ok +table(m.new.chroma$V) + + +## TODO: flag within single data.frame, these two are out of sync ## graphical check g <- make.groups( m.new.chroma, - m.2.5.values + zz ) # ok -xyplot(x ~ V | factor(C), groups = which, data = g, subset = H %in% c('2.5YR'), type = 'p', par.settings = tactile.theme(), as.table = TRUE, scales = list(alternating = 1), cex = 0.5, pch = 16, xlim = c(0, 10)) +xyplot( + x ~ V | factor(C), + groups = which, + data = g, + subset = H %in% c('2.5YR'), + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 0.5, + pch = 16, + xlim = c(0, 10) +) + +xyplot( + y ~ V | factor(C), + groups = which, + data = g, + subset = H %in% c('2.5YR'), + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 0.5, + pch = 16, + xlim = c(0, 10) +) + +xyplot( + x ~ V | factor(C), + groups = which, + data = g, + subset = H %in% c('5G'), + type = 'p', + par.settings = tactile.theme(), + as.table = TRUE, + scales = list(alternating = 1), + cex = 0.5, + pch = 16, + xlim = c(0, 10) +) + + +.n <- length(unique(m.new.chroma$C[m.new.chroma$H %in% c('2.5Y', '2.5YR', '2.5R')])) +.cols <- hcl.colors(n = .n, palette = 'zissou1') + +xyplot( + x ~ V | factor(H), + groups = C, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'b', + par.settings = tactile.theme( + background = list(col = 'black'), + axis.text = list(col = 'white'), + par.xlab.text = list(col = 'white'), + par.ylab.text = list(col = 'white'), + superpose.symbol = list(col = .cols, pch = 16), + superpose.line = list(col = .cols, lwd = 1) + ), + as.table = TRUE, + scales = list(alternating = 1, x = list(at = seq(1, 10))), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) + +xyplot( + x ~ V | factor(H), + groups = C, + data = m.new.chroma, + subset = H %in% c('2.5Y', '2.5YR', '2.5R'), + type = 'b', + par.settings = tactile.theme( + superpose.symbol = list(col = .cols, pch = 16), + superpose.line = list(col = .cols, lwd = 1) + ), + as.table = TRUE, + scales = list(alternating = 1, x = list(at = seq(1, 10))), + panel = function(...) { + panel.grid(-1, -1) + panel.xyplot(...) + } +) @@ -112,8 +425,13 @@ summary(m.XYZ) m.sRGB <- XYZ2rgb(m.XYZ) ## check: -# probably the same +# should give the same results +# note explicit reference illuminant conversion XYZ coordinates are D65 # z <- convertColor(m.XYZ, from = 'XYZ', to = 'sRGB', from.ref.white = 'D65', to.ref.white = 'D65') +# +# relatively small differences +# colMeans(m.sRGB - z) + m.final <- data.frame(m.new.chroma, m.sRGB) @@ -121,15 +439,20 @@ m.final <- data.frame(m.new.chroma, m.sRGB) plot_cols <- rgb(m.final$R, m.final$G, m.final$B) -p1 <- xyplot(V ~ C | factor(H, levels=c('2.5Y', '10YR', '7.5YR', '5YR', '2.5YR', '10R')), - main="Common Soil Colors", - data=m.final, subset=H %in% c('2.5Y', '10YR', '7.5YR', '5YR', '2.5YR', '10R') & V > 1 & V <= 8 & C <= 8, - as.table=TRUE, subscripts=TRUE, xlab='Chroma', ylab='Value', - par.settings = tactile.theme(), - panel=function(x, y, subscripts, ...) - { - panel.xyplot(x, y, pch=15, cex=2, col=plot_cols[subscripts]) - } +p1 <- xyplot( + V ~ C | factor(H, levels = c('2.5Y', '10YR', '7.5YR', '5YR', '2.5YR', '10R')), + main = "Common Soil Colors", + data = m.final, + subset = H %in% c('2.5Y', '10YR', '7.5YR', '5YR', '2.5YR', '10R') & V <= 8 & C <= 8, + as.table = TRUE, + subscripts = TRUE, + scales = list(alternating = 1, y = list(at = 1:8)), + xlab = 'Chroma', + ylab = 'Value', + par.settings = tactile.theme(), + panel = function(x, y, subscripts, ...) { + panel.xyplot(x, y, pch = 15, cex = 2, col = plot_cols[subscripts]) + } ) p1 @@ -175,9 +498,12 @@ n.agg.final <- n.agg.final[order(n.agg.final$V), ] # combine m.final <- rbind(m.final, n.agg.final) -# 9227 +# 2022: 9,227 (2.5 value chips) +# 2024a: 15,709 (all half-value chips) +# 2024b: 10,447 (select half-value chips) nrow(m.final) + ## ## add CIELAB coordinates ## @@ -192,17 +518,32 @@ row.names(m.final.lab) <- NULL str(m.final.lab) + ## -## check +## check differences from previous versions of the LUT ## +## 2022: +## the new N chips are the top differences +## everything else has dE00 < 4 +## mostly value == 1 + + +## 2024: +## dE00 > 0.4 (but all < 1.5) are 2.5 value chips +## +## likely related to interpolation over full range of V vs. single, linear interpolation 2->2.5<-3 + + + + ## make backup copy of old LUT # data(munsell) -# saveRDS(munsell, file = 'munsell-LUT-2022-03-29.rds') +# saveRDS(munsell, file = 'munsell-LUT-2024-09-25.rds') -z.old <- readRDS('munsell-LUT-2022-03-29.rds') +z.old <- readRDS('munsell-LUT-2024-09-25.rds') -z <- merge(z.old, m.final.lab, by = c('hue', 'value', 'chroma'), all.x = TRUE) +z <- merge(z.old, m.final.lab, by = c('hue', 'value', 'chroma'), all.x = TRUE, sort = FALSE) str(z) @@ -226,10 +567,13 @@ for(i in 1:nrow(z)) { from_space = 'lab', to_space = 'lab', white_from = 'D65', - white_to = 'D65', method = 'cie2000' + white_to = 'D65', + method = 'cie2000' ) } +hist(d) + # changes with dE00 > 2 idx <- which(d > 2) @@ -243,9 +587,19 @@ table(zz$hue) table(zz$value) table(zz$chroma) -## N chips are the top differences -## everything else is dE00 < 4 -## mostly value == 1 + +# changes with dE00 > 0.4 +idx <- which(d > 0.4) +zz <- z[idx, ] +zz$dE00 <- d[idx] +zz <- zz[order(zz$dE00, decreasing = TRUE), ] + +nrow(zz) +head(zz, 20) + +table(zz$hue) +table(zz$value) +table(zz$chroma) @@ -257,23 +611,31 @@ munsell <- m.final.lab save(munsell, file = '../../../data/munsell.rda', compress = 'xz') -## install / or reload from source - - -munsell2rgb('10YR', 3.5, 2, returnLAB = TRUE) -munsell2rgb('10YR', 4, 2, returnLAB = TRUE) - -munsell2rgb('10YR', 2.5, 2, returnLAB = TRUE) -munsell2rgb('10YR', 2, 2, returnLAB = TRUE) - -munsell2rgb('10YR', 2, 1, returnLAB = TRUE) -munsell2rgb('10YR', 5, 1, returnLAB = TRUE) - - -# check neutral -m <- sprintf('N %s/', 2:9) -cols <- parseMunsell(m) -soilPalette(cols, lab = m) - +## install / or reload from source +# +# munsell2rgb('10YR', 9, 2, returnLAB = TRUE) +# munsell2rgb('10YR', 9.5, 2, returnLAB = TRUE) +# +# # dE00 ~ 3 +# # colorContrastPlot('10YR 9/2', '10YR 9.5/2') +# +# +# munsell2rgb('10YR', 3.5, 2, returnLAB = TRUE) +# munsell2rgb('10YR', 4, 2, returnLAB = TRUE) +# +# munsell2rgb('10YR', 2.5, 2, returnLAB = TRUE) +# munsell2rgb('10YR', 2, 2, returnLAB = TRUE) +# +# munsell2rgb('10YR', 2, 1, returnLAB = TRUE) +# munsell2rgb('10YR', 5, 1, returnLAB = TRUE) +# +# +# # check neutral +# m <- sprintf('N %s/', c(2, 2.5, 3:8)) +# cols <- parseMunsell(m) +# soilPalette(cols, lab = m) +# +# +# diff --git a/misc/utils/Munsell/prepare-simplfied-spectra-library.R b/misc/utils/Munsell/prepare-simplfied-spectra-library.R index 2526568a5..349b49215 100644 --- a/misc/utils/Munsell/prepare-simplfied-spectra-library.R +++ b/misc/utils/Munsell/prepare-simplfied-spectra-library.R @@ -1,3 +1,7 @@ +## Simplify the Munsell spectral reference data for later use. Results are temporary. +## +## + library(reshape2) # missing odd chroma diff --git a/tests/testthat/test-SPC-objects.R b/tests/testthat/test-SPC-objects.R index f94409f74..dd433a08b 100644 --- a/tests/testthat/test-SPC-objects.R +++ b/tests/testthat/test-SPC-objects.R @@ -611,15 +611,15 @@ test_that("basic integrity checks", { expect_true(spc_in_sync(spc[0,])$valid) # reordering the horizons with reorderHorizons resolves integrity issues - expect_true(spc_in_sync(reorderHorizons(spc))$valid) + expect_true(spc_in_sync(reorderHorizons(spc, seq(nrow(spc))))$valid) - # default reordering uses metadata$original.order, here we override and reverse it - expect_false(spc_in_sync(reorderHorizons(spc, rev(spc@metadata$original.order)))$valid) + # override and reverse it + expect_false(spc_in_sync(reorderHorizons(spc, rev(seq(nrow(spc)))))$valid) # removing the metadata works because target order matches sequential order # this cannot be guaranteed to be the case in general but is a reasonable default spc@metadata$target.order <- NULL - expect_true(spc_in_sync(reorderHorizons(spc))$valid) + expect_true(spc_in_sync(reorderHorizons(spc, seq(nrow(spc))))$valid) # reordering horizons with any order works, even if invalid spc <- reorderHorizons(spc, target.order = c(20:40,1:19)) diff --git a/tests/testthat/test-argillic.R b/tests/testthat/test-argillic.R index 62be4b2a1..e1ea1d976 100644 --- a/tests/testthat/test-argillic.R +++ b/tests/testthat/test-argillic.R @@ -5,6 +5,8 @@ depths(sp1) <- id ~ top + bottom site(sp1) <- ~ group p <- sp1[1] +hzdesgnname(p) <- "name" +hztexclname(p) <- "texture" clay.attr <- 'prop' # clay contents % texcl.attr <- 'texture' # class containing textural class (for finding sandy textures) @@ -41,31 +43,14 @@ test_that("argillic.clay.increase() (used for getArgillicBounds())", { test_that("getArgillicBounds()", { - # name and texture class are guessable - d <- getArgillicBounds(p, clay.attr='prop') - + # name and texture class are determined from metadata + d <- getArgillicBounds(p, clay.attr = 'prop') + # this makes sure estimateSoilDepth() isn't broken... expect_equivalent(d, c(49, 89)) - - # no error when hzdesgn and texcl.attr are unknown, due to guessing function - d1 <- getArgillicBounds(p, hzdesgn='foo', clay.attr='prop', texcl.attr = 'bar') - expect_equivalent(d1, c(49, 89)) - - # deliberately break the reasoning guessing - # returns correct result because of slots - p$goo <- p$name - p$boo <- p$texture - p$name <- NULL - p$texture <- NULL - - expect_error(getArgillicBounds(p, hzdesgn='foo', clay.attr='prop', texcl.attr = 'bar')) - - # set the desgn name and texture class slots - hzdesgnname(p) <- "goo" - hztexclname(p) <- "boo" - - d2 <- getArgillicBounds(p, hzdesgn='foo', clay.attr='prop', texcl.attr = 'bar') - expect_equivalent(d2, c(49, 89)) + + # error when hzdesgn and texcl.attr are unknown; no guessing + expect_error(getArgillicBounds(p, hzdesgn = 'foo', clay.attr = 'prop', texcl.attr = 'bar')) }) test_that("getArgillicBounds - error conditions", { diff --git a/tests/testthat/test-cambic.R b/tests/testthat/test-cambic.R index 271b62391..6e5b2c669 100644 --- a/tests/testthat/test-cambic.R +++ b/tests/testthat/test-cambic.R @@ -16,6 +16,7 @@ spc <- data.frame(id = 1, taxsubgrp = "Lithic Haploxerepts", depths(spc) <- id ~ hzdept + hzdepb hzdesgnname(spc) <- 'hzname' hztexclname(spc) <- 'texcl' +hzmetaname(spc, "clay") <- 'clay' test_that("getCambicBounds - basic functionality", { dfbound <- getCambicBounds(spc) diff --git a/tests/testthat/test-color-conversion.R b/tests/testthat/test-color-conversion.R index a846962c7..d4d3838fa 100644 --- a/tests/testthat/test-color-conversion.R +++ b/tests/testthat/test-color-conversion.R @@ -107,10 +107,11 @@ test_that("Munsell hue parsing", { }) -test_that("non-integer value and chroma are selectively rounded", { +test_that("non-integer value and chroma are snapped to valid possibilities", { # rounding of value, throws warning expect_warning(res <- parseMunsell('10YR 3.3/4'), regexp = 'non-standard notation') + # this will not throw a warning res <- parseMunsell('10YR 3.3/4', convertColors = FALSE) @@ -120,6 +121,23 @@ test_that("non-integer value and chroma are selectively rounded", { parseMunsell('10YR 3/4') ) + # 2.5, 8.5, 9.5 are valid Munsell value + # snap nearby to these + expect_equal( + suppressWarnings(parseMunsell('10YR 2.6/4')), + parseMunsell('10YR 2.5/4') + ) + + expect_equal( + suppressWarnings(parseMunsell('10YR 8.4/4')), + parseMunsell('10YR 8.5/4') + ) + + expect_equal( + suppressWarnings(parseMunsell('10YR 9.55/4')), + parseMunsell('10YR 9.5/4') + ) + # rounding of chroma, throws warning expect_warning(res <- parseMunsell('10YR 3/4.6'), regexp = 'non-standard notation') # this will not throw a warning @@ -131,11 +149,24 @@ test_that("non-integer value and chroma are selectively rounded", { parseMunsell('10YR 3/5') ) - # no rounding of 2.5 values + # double-check no snapping of 2.5 values res <- parseMunsell('10YR 2.5/2') res.test <- col2Munsell(col = '#493A2BFF') expect_true(res.test$value == 2.5) + + + # test .snapValid() directly + .valid <- c(2, 2.5, 3, 4, 5, 6, 7, 8, 8.5, 9, 9.5, 10) + v <- c(2, 4, 6, 8, NA, 2.5, 2.6, 8.1, 9.6, 12) + res <- aqp:::.snapValid(v, .valid) + + # ensure snapping worked as expected + expect_equal( + res, + c(2, 4, 6, 8, NA, 2.5, 2.5, 8, 9.5, 10) + ) + }) @@ -235,6 +266,9 @@ test_that("neutral hues", { expect_equal(N4, '#1B1C1CFF') expect_equal(N6, '#464848FF') + # 0 chroma with any hue -> neutral + N <- munsell2rgb('10YR', 4, 0) + expect_equal(N, '#1B1C1CFF') }) diff --git a/tests/testthat/test-color-signature.R b/tests/testthat/test-color-signature.R index 5b8ed2dcf..e314d0a26 100644 --- a/tests/testthat/test-color-signature.R +++ b/tests/testthat/test-color-signature.R @@ -26,11 +26,11 @@ test_that("colorBucket", { # add more of these expect_equal(pig$id[1], 'P001') - expect_equal(pig$.white.pigment[1], 0.6351809, tolerance=0.001) - expect_equal(pig$.red.pigment[1], 0.10308427, tolerance=0.001) - expect_equal(pig$.green.pigment[1], 0, tolerance=0.001) - expect_equal(pig$.yellow.pigment[1], 0.2617348, tolerance=0.001) - expect_equal(pig$.blue.pigment[1], 0, tolerance=0.001) + expect_equal(pig$.white.pigment[1], 0.635, tolerance = 0.001) + expect_equal(pig$.red.pigment[1], 0.103, tolerance = 0.001) + expect_equal(pig$.green.pigment[1], 0, tolerance = 0.001) + expect_equal(pig$.yellow.pigment[1], 0.261, tolerance = 0.001) + expect_equal(pig$.blue.pigment[1], 0, tolerance = 0.001) }) @@ -46,11 +46,11 @@ test_that("depthSlices", { # add more of these expect_equal(pig$id[1], 'P001') - expect_equal(pig$A.0.1[1], 5.8741, tolerance=0.001) - expect_equal(pig$A.0.5[1], 5.5744, tolerance=0.001) - expect_equal(pig$B.0.1[1], 11.0712, tolerance=0.001) - expect_equal(pig$B.0.5[1], 17.8611, tolerance=0.001) - expect_equal(pig$L.0.1[1], 30.2502, tolerance=0.001) + expect_equal(pig$A.0.1[1], 5.87, tolerance = 0.01) + expect_equal(pig$A.0.5[1], 5.57, tolerance = 0.01) + expect_equal(pig$B.0.1[1], 11.07, tolerance = 0.01) + expect_equal(pig$B.0.5[1], 17.86, tolerance = 0.01) + expect_equal(pig$L.0.1[1], 30.25, tolerance = 0.01) }) diff --git a/tests/testthat/test-equivalentMunsellChips.R b/tests/testthat/test-equivalentMunsellChips.R new file mode 100644 index 000000000..c5c867799 --- /dev/null +++ b/tests/testthat/test-equivalentMunsellChips.R @@ -0,0 +1,39 @@ +test_that("equivalentMunsellChips works", { + + # same "chip page position" different hue page; identify all perceptually equivalent chips + + # test 1 + a <- as.list(equivalentMunsellChips("7.5YR", 2, 1)[[1]][, c("hue", "value", "chroma")]) + + b <- list( + hue = c("10YR", "5YR", "7.5YR"), + value = c(2, 2, 2), + chroma = c(1, 1, 1) + ) + + expect_equal(a, b) + + + # test 2 + a <- as.list(equivalentMunsellChips("5YR", 2, 1)[[1]][, c("hue", "value", "chroma")]) + + b <- list( + hue = c("10R", "2.5YR", "5YR", "7.5YR"), + value = c(2, 2, 2, 2), + chroma = c(1, 1, 1, 1) + ) + + expect_equal(a, b) + + # test 3 + a <- as.list(equivalentMunsellChips("10YR", 2, 1)[[1]][, c("hue", "value", "chroma")]) + + b <- list( + hue = c("10YR", "2.5Y", "7.5YR"), + value = c(2, 2, 2), + chroma = c(1, 1, 1) + ) + + expect_equal(a, b) + +}) diff --git a/tests/testthat/test-estimatePSCS.R b/tests/testthat/test-estimatePSCS.R index 5fe3067f2..f48561c50 100644 --- a/tests/testthat/test-estimatePSCS.R +++ b/tests/testthat/test-estimatePSCS.R @@ -77,8 +77,8 @@ test_that("estimatePSCS()", { }) test_that("estimatePSCS() thin soil profile with O horizon", { - expect_equal(estimatePSCS(x, clay.attr = 'prop', texcl.attr = "foo", hzdesgn = 'name'), c(13, 40)) - expect_equal(estimatePSCS(c(q,x), clay.attr = 'prop', texcl.attr = "foo", hzdesgn = 'name'), + expect_equal(estimatePSCS(x, clay.attr = 'prop', texcl.attr = "texture", hzdesgn = 'name'), c(13, 40)) + expect_equal(estimatePSCS(c(q,x), clay.attr = 'prop', texcl.attr = "texture", hzdesgn = 'name'), data.frame(id = c("706300", "P002"), pscs_top = c(13, 30), pscs_bottom = c(40, 59))) diff --git a/tests/testthat/test-flagOverlappingHz.R b/tests/testthat/test-flagOverlappingHz.R index 1bfa2dbc0..d8836ac6c 100644 --- a/tests/testthat/test-flagOverlappingHz.R +++ b/tests/testthat/test-flagOverlappingHz.R @@ -10,7 +10,7 @@ z <- data.frame( depths(z) <- id ~ top + bottom # basic functionality -test_that("flagOverlappingHz", { +test_that("flagOverlappingHz: perfect overlap in 2 horizons", { .overlapFlag <- flagOverlappingHz(z) @@ -26,6 +26,29 @@ test_that("flagOverlappingHz", { }) +z2 <- data.frame( + id = 'SPC', + top = c(0, 25, 25, 25, 50, 75, 100, 100), + bottom = c(25, 45, 50, 50, 75, 100, 125, 125) +) + +depths(z2) <- id ~ top + bottom + +test_that("flagOverlappingHz: imperfect in 1 horizon, perfect in 2 horizons", { + + .overlapFlag <- flagOverlappingHz(z2) + + # logical vector + expect_true(length(.overlapFlag) == nrow(z2)) + expect_true(inherits(.overlapFlag, 'logical')) + + # not overlapping horizons + expect_true(all(!.overlapFlag[c(1, 2, 5, 6)])) + + # overlapping horizons + expect_true(all(.overlapFlag[c(3, 4, 7, 8)])) + +}) # more complex edge case x <- data.frame(peiid = c("1373969", "1373969", "1373969", "1373969", @@ -46,3 +69,47 @@ test_that("edge case", { TRUE, TRUE, TRUE, FALSE, FALSE)) }) + + +z3 <- data.frame( + id = 'SPC1', + top = c(0, 25, 25, 25, 50, 75, 100, 100), + bottom = c(25, 45, 50, 50, 75, 100, 125, 125) +) + +z4 <- data.frame( + id = 'SPC2', + top = c(0, 25, 50, 75, 100), + bottom = c(25, 50, 75, 100, 125) +) + +z5 <- rbind(z3, z4) +depths(z5) <- id ~ top + bottom + +# test multiple profiles with some depths the same between both profiles +# but only the first profile has overlap (1 imperfect, 2 perfect) +test_that("multiple profiles, with and without overlap", { + .overlapFlag <- flagOverlappingHz(z5) + expect_false(any(.overlapFlag[9:13])) +}) + +z6 <- data.frame( + id = 'SPC1', + top = 0, + bottom = 100 +) + +z7 <- data.frame( + id = 'SPC2', + top = c(0, 0, 100), + bottom = c(100, 100, 200) +) + +z8 <- rbind(z6, z7) +depths(z8) <- id ~ top + bottom + +test_that("multiple profiles, edge case", { + # first single horizon profile matches depths that overlap in next profile + .overlapFlag <- flagOverlappingHz(z8) + expect_false(.overlapFlag[1]) +}) diff --git a/tests/testthat/test-glom.R b/tests/testthat/test-glom.R index fa5ece315..6635648ba 100644 --- a/tests/testthat/test-glom.R +++ b/tests/testthat/test-glom.R @@ -217,5 +217,11 @@ test_that("glom vectorization", { # truncate twice, initially with drop=FALSE expect_equal(length(trunc(trunc(sp1, 75, 100, drop = FALSE), 90, 100)), 4) + + # no horizons in glom interval, with missing profiles dropped + expect_equal(length(trunc(sp1, 250, 300)), 0) + + # no horizons in glom interval, with missing profiles filled + expect_equal(length(trunc(sp1, 250, 300, drop = FALSE)), 9) }) diff --git a/tests/testthat/test-guessColumnNames.R b/tests/testthat/test-guessColumnNames.R index c9cbf5dd7..29328c956 100644 --- a/tests/testthat/test-guessColumnNames.R +++ b/tests/testthat/test-guessColumnNames.R @@ -8,7 +8,7 @@ depths(sp3) <- id ~ top + bottom test_that("basic functionality", { # historic horizon designation name (e.g. used by plotSPC) - expect_equal(guessHzDesgnName(sp3), "name") + expect_warning(expect_equal(guessHzDesgnName(sp3), "name")) # basic attribute name guessing expect_message(expect_equal(guessHzAttrName(sp3, "clay", ""), "clay"), @@ -25,32 +25,31 @@ test_that("basic functionality", { "guessing horizon attribute 'clay' is stored in `claytotal_r`") # basic attribute name guessing - expect_equal(guessHzTexClName(sp3), "") + expect_warning(expect_equal(guessHzTexClName(sp3), "")) # texcl horizons(sp3)$texcl <- "l" - expect_equal(guessHzTexClName(sp3), "texcl") + expect_warning(expect_equal(guessHzTexClName(sp3), "texcl")) # texture sp3$texture <- sp3$texcl sp3$texcl <- NULL - expect_equal(guessHzTexClName(sp3), "texture") + expect_warning(expect_equal(guessHzTexClName(sp3), "texture")) # descriptive name sp3$hzdesgn <- sp3$name sp3$name <- NULL sp3$desgn <- 1:nrow(sp3) - expect_equal(guessHzDesgnName(sp3), "hzdesgn") + expect_warning(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") + expect_warning(expect_equal(guessHzDesgnName(sp3), NA)) # custom name hzdesgnname(sp3) <- "foo" - expect_equal(guessHzDesgnName(sp3), "foo") + expect_warning(expect_equal(guessHzDesgnName(sp3), "foo")) }) diff --git a/tests/testthat/test-mixMunsell.R b/tests/testthat/test-mixMunsell.R index 854d31b7a..347e348fc 100644 --- a/tests/testthat/test-mixMunsell.R +++ b/tests/testthat/test-mixMunsell.R @@ -97,7 +97,7 @@ test_that("mixing methods, except reference", { # fall-back to wt.mean CIELAB expect_message(mx <- mixMunsell(c('10YR 6/2', '10YR 1/1'), mixingMethod = 'adaptive')) - expect_true(mx$munsell[1] == '2.5Y 3/2') + expect_true(mx$munsell[1] == '10YR 3/1') }) diff --git a/tests/testthat/test-mollic.R b/tests/testthat/test-mollic.R index 4dbefd72a..d8870998e 100644 --- a/tests/testthat/test-mollic.R +++ b/tests/testthat/test-mollic.R @@ -28,10 +28,12 @@ spc2 <- data.frame( depths(spc) <- id ~ hzdept + hzdepb hzdesgnname(spc) <- 'hzname' hztexclname(spc) <- 'texcl' +hzmetaname(spc, "clay") <- 'prop' depths(spc2) <- id ~ hzdept + hzdepb hzdesgnname(spc2) <- 'hzname' hztexclname(spc2) <- 'texcl' +hzmetaname(spc2, "clay") <- 'claytotest' spc3 <- data.frame(pedon_key = c("10016", "10016", "10016", "10047", "10047", "10047", "10047", "10047", "10047", "10047"), @@ -46,6 +48,7 @@ spc3 <- data.frame(pedon_key = c("10016", "10016", "10016", "10047", "10047", depths(spc3) <-pedon_key ~ hzn_top + hzn_bot hzdesgnname(spc3) <- "hzn_desgn" hztexclname(spc3) <- "texture_lab" +hzmetaname(spc3, "clay") <- "clay_total" test_that("mollic.thickness.requirement", { expect_equal(mollic.thickness.requirement(spc, clay.attr = 'prop'), 18) diff --git a/tests/testthat/test-segment.R b/tests/testthat/test-segment.R index 760540ec8..5e83d9391 100644 --- a/tests/testthat/test-segment.R +++ b/tests/testthat/test-segment.R @@ -1,4 +1,4 @@ -context("segment") +context("hz_segment") test_that("data.frame interface works as expected", { @@ -7,7 +7,7 @@ test_that("data.frame interface works as expected", { data(sp1) # trimming - z <- segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE, hzdepcols = c('top', 'bottom')) + z <- hz_segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE, depthcols = c('top', 'bottom')) # correct object type and segment label expect_true(inherits(z, 'data.frame')) @@ -17,7 +17,7 @@ test_that("data.frame interface works as expected", { expect_true(inherits(z[['segment_id']], 'character')) # no triming - z <- segment(sp1, intervals = c(0, 10, 20, 30), trim = FALSE, hzdepcols = c('top', 'bottom')) + z <- hz_segment(sp1, intervals = c(0, 10, 20, 30), trim = FALSE, depthcols = c('top', 'bottom')) # correct object type and segment label expect_true(inherits(z, 'data.frame')) @@ -35,7 +35,7 @@ test_that("SPC interface works as expected", { depths(sp1) <- id ~ top + bottom # trimming - z <- segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE) + z <- hz_segment(sp1, intervals = c(0, 10, 20, 30), trim = TRUE) expect_true(inherits(z, 'SoilProfileCollection')) expect_true('segment_id' %in% horizonNames(z)) @@ -44,7 +44,7 @@ test_that("SPC interface works as expected", { expect_true(inherits(z[['segment_id']], 'character')) # no trimming - z <- segment(sp1, intervals = c(0, 10, 20, 30), trim = FALSE) + z <- hz_segment(sp1, intervals = c(0, 10, 20, 30), trim = FALSE) expect_true(inherits(z, 'SoilProfileCollection')) expect_true('segment_id' %in% horizonNames(z)) @@ -69,8 +69,8 @@ test_that("expected outcome with NA horizon depths", { bad$top[c(1, 5)] <- NA # segment - z.bad <- segment(bad, intervals = c(0, 10, 20, 30), trim = TRUE, hzdepcols = c('top', 'bottom')) - z.good <- segment(good, intervals = c(0, 10, 20, 30), trim = TRUE, hzdepcols = c('top', 'bottom')) + z.bad <- hz_segment(bad, intervals = c(0, 10, 20, 30), trim = TRUE, depthcols = c('top', 'bottom')) + z.good <- hz_segment(good, intervals = c(0, 10, 20, 30), trim = TRUE, depthcols = c('top', 'bottom')) # label class expect_true(inherits(z.good[['segment_id']], 'character')) @@ -86,34 +86,35 @@ test_that("expected outcome with NA horizon depths", { }) -test_that("expected outcome with bogus horizon depths", { - - # init local copy of sample data - data(sp1) - - # copies - good <- sp1 - bad <- sp1 - - # add NA to horizon depths - bad$top[c(1, 5)] <- bad$bottom[c(1, 5)] - - # segment - z.bad <- segment(bad, intervals = c(0, 10, 20, 30), trim = TRUE, hzdepcols = c('top', 'bottom')) - z.good <- segment(good, intervals = c(0, 10, 20, 30), trim = TRUE, hzdepcols = c('top', 'bottom')) - - # label class - expect_true(inherits(z.good[['segment_id']], 'character')) - expect_true(inherits(z.bad[['segment_id']], 'character')) - - ## TODO: is this expected? - # row count - expect_false(nrow(z.good) == nrow(z.bad)) - - # same values - # expect_false(all(z.good$segment_id == z.bad$segment_id)) - -}) +# I think this test needs to be retired or reframed. segment previously exclude results where the thickness of the segment was zero. That feature has been removed. Upon updating segment it was removed to ensure the original data was returned regardless of the horizon errors, which should be dealt with elsewhere. +# test_that("expected outcome with bogus horizon depths", { +# +# # init local copy of sample data +# data(sp1) +# +# # copies +# good <- sp1 +# bad <- sp1 +# +# # add NA to horizon depths +# bad$top[c(1, 5)] <- bad$bottom[c(1, 5)] +# +# # segment +# z.bad <- hz_segment(bad, intervals = c(0, 10, 20, 30), trim = TRUE, depthcols = c('top', 'bottom')) +# z.good <- hz_segment(good, intervals = c(0, 10, 20, 30), trim = TRUE, depthcols = c('top', 'bottom')) +# +# # label class +# expect_true(inherits(z.good[['segment_id']], 'character')) +# expect_true(inherits(z.bad[['segment_id']], 'character')) +# +# ## TODO: is this expected? +# # row count +# expect_false(nrow(z.good) == nrow(z.bad)) +# +# # same values +# # expect_false(all(z.good$segment_id == z.bad$segment_id)) +# +# }) @@ -128,7 +129,7 @@ test_that("same results as weighted mean via slab", { a.slab <- slab(s, fm = ~ p1, slab.structure = c(0, 10, 20, 30), slab.fun = mean, na.rm = TRUE) # segment - z <- segment(s, intervals = c(0, 10, 20, 30), trim = TRUE) + z <- hz_segment(s, intervals = c(0, 10, 20, 30), trim = TRUE) # compute horizon thickness weights z <- horizons(z) diff --git a/tests/testthat/test-similarMunsellChips.R b/tests/testthat/test-similarMunsellChips.R deleted file mode 100644 index 3a2970359..000000000 --- a/tests/testthat/test-similarMunsellChips.R +++ /dev/null @@ -1,49 +0,0 @@ -context("Equivalent Munsell Chips") - - - -test_that("equivalentMunsellChips works", { - - # same "chip page position" different hue page; identify all perceptually equivalent chips - - # test 1 - a <- as.list( - equivalentMunsellChips("7.5YR", 2, 1)[[1]][, c("hue","value","chroma")] - ) - - b <- list( - hue = c("10YR", "2.5YR", "5YR", "7.5YR"), - value = c(2, 2, 2, 2), - chroma = c(1, 1, 1, 1) - ) - - expect_equal(a, b) - - - # test 2 - a <- as.list( - equivalentMunsellChips("5YR", 2, 1)[[1]][, c("hue","value","chroma")] - ) - - b <- list( - hue = c("10R", "10YR", "2.5YR", "5YR", "7.5YR"), - value = c(2, 2, 2, 2, 2), - chroma = c(1, 1, 1, 1, 1) - ) - - expect_equal(a, b) - - # test 3 - a <- as.list( - equivalentMunsellChips("10YR", 2, 1)[[1]][,c("hue", "value", "chroma")] - ) - - b <- list( - hue = c("10YR", "2.5Y", "5YR", "7.5YR"), - value = c(2, 2, 2, 2), - chroma = c(1, 1, 1, 1) - ) - - expect_equal(a, b) - -}) diff --git a/tests/testthat/test-soil-depth.R b/tests/testthat/test-soil-depth.R index 8a582ebcb..9459588df 100644 --- a/tests/testthat/test-soil-depth.R +++ b/tests/testthat/test-soil-depth.R @@ -30,7 +30,7 @@ d <- depths(d) <- id ~ top + bottom - +hzdesgnname(d) <- "name" ## tests @@ -39,6 +39,7 @@ test_that("error conditions", { # function will only accept a single profile expect_error(estimateSoilDepth(d, name='name')) + hzdesgnname(d) <- "" # not specified -> error expect_error(profileApply(d, estimateSoilDepth)) diff --git a/tests/testthat/test-spec2Munsell.R b/tests/testthat/test-spec2Munsell.R index 47907c529..eb615ab0b 100644 --- a/tests/testthat/test-spec2Munsell.R +++ b/tests/testthat/test-spec2Munsell.R @@ -27,7 +27,7 @@ test_that("spec2Munsell works as expected", { ) # expected dE00 - expect_equal(m$sigma, 0.64280, tolerance = 1e-4) + expect_equal(m$sigma, 0.64280, tolerance = 0.01) }) diff --git a/tests/testthat/test-surface-thickness.R b/tests/testthat/test-surface-thickness.R index 2f35ca4be..af63788bd 100644 --- a/tests/testthat/test-surface-thickness.R +++ b/tests/testthat/test-surface-thickness.R @@ -5,6 +5,7 @@ context("surface horizon thickness, mineral soil surface, organic soil horizon") data(sp1, package = 'aqp') depths(sp1) <- id ~ top + bottom site(sp1) <- ~ group +hzdesgnname(sp1) <- "name" p <- sp1[1] attr <- 'prop' # clay contents % diff --git a/tests/testthat/test-thicknessOf.R b/tests/testthat/test-thicknessOf.R new file mode 100644 index 000000000..45cf5eedd --- /dev/null +++ b/tests/testthat/test-thicknessOf.R @@ -0,0 +1,44 @@ +test_that("thicknessOf works", { + data("jacobs2000") + + ## method="cumulative" + + # cumulative thickness of horizon designations matching "A|B" + x1 <- thicknessOf(jacobs2000, "A|B", prefix = "AorB_") + expect_equal(nrow(x1), length(jacobs2000)) + expect_equal(x1$AorB_thickness, c(131, 117, 136, 20, 54, 110, 43)) + + ## method="minmax" + + # maximum bottom depth minus minimum top depth of horizon designations matching "A|B" + x2 <- thicknessOf(jacobs2000, "A|B", method = "minmax", prefix = "AorB_") + expect_equal(ncol(x2), 4) + expect_equal(x2$AorB_top, rep(0, nrow(x2))) + expect_equal(x2$AorB_thickness, c(156, 145, 175, 20, 135, 168, 140)) + expect_true(all(x2$AorB_thickness >= x1$AorB_thickness)) + + ## custom logical function + + # calculate cumulative thickness of horizons containing >18% clay + x3 <- thicknessOf(jacobs2000, FUN = function(x, ...) !is.na(x[["clay"]]) & x[["clay"]] > 18) + expect_equal(x3$thickness, c(170, 167, 81, 0, 0, 49, 0)) + + ## missing property and or depth data + + # function without NA handling, and na.rm=FALSE + x4 <- thicknessOf(jacobs2000, FUN = function(x, ...) x[["clay"]] > 18) + expect_equal(x4$thickness, c(170, 167, 81, 0, NA_integer_, 49, 0)) + + # function without NA handling, and na.rm=TRUE + x5 <- thicknessOf(jacobs2000, FUN = function(x, ...) x[["clay"]] > 18, na.rm = TRUE) + expect_equal(x5$thickness, c(170, 167, 81, 0, 0, 49, 0)) + + # missing horizon depths, and na.rm=FALSE + jacobs2000@horizons$top[1] <- NA_integer_ + x6 <- thicknessOf(jacobs2000, "A|B") + expect_equal(x6$thickness, c(NA_integer_, 117, 136, 20, 54, 110, 43)) + + # missing horizond depths, and na.rm = TRUE + x7 <- thicknessOf(jacobs2000, "A|B", na.rm = TRUE) + expect_equal(x7$thickness, c(113, 117, 136, 20, 54, 110, 43)) +}) diff --git a/vignettes/Munsell-color-conversion.Rmd b/vignettes/Munsell-color-conversion.Rmd index 407d4b5af..5d608c347 100644 --- a/vignettes/Munsell-color-conversion.Rmd +++ b/vignettes/Munsell-color-conversion.Rmd @@ -61,7 +61,7 @@ axis(side = 2, las = 1) Neutral colors are commonly specified two ways in the Munsell system: `N 3/` or `N 3/0`, either format will work with `munsell2rgb()` and `parseMunsell()`. -Non-standard Munsell notation (e.g. `3.6YR 4.4 / 5.6`), possibly collected with a sensor vs. color book, can be approximated with `getClosestMunsellChip()`. A more accurate conversion can be performed with the [`munsellinterpol` package.](https://cran.r-project.org/web/packages/munsellinterpol/index.html). +Non-standard Munsell notation (e.g. `3.6YR 4.4 / 5.6`), possibly collected with a sensor vs. color book, can be approximated with `getClosestMunsellChip()`. A more accurate conversion can be performed with the [`munsellinterpol` package.](https://cran.r-project.org/package=munsellinterpol). ## Examples diff --git a/vignettes/new-in-aqp-2.Rmd b/vignettes/new-in-aqp-2.Rmd index f5bf3234b..b54fd7cf2 100644 --- a/vignettes/new-in-aqp-2.Rmd +++ b/vignettes/new-in-aqp-2.Rmd @@ -73,6 +73,7 @@ The `replace_na` and `add_soil_flag` arguments to `profile_compare()` are not pr * New [depth axis styles](https://ncss-tech.github.io/AQP/aqp/sketches.html) in `plotSPC()`. * New function `flagOverlappingHz()` for identifying horizons with perfect overlap * New function `warpHorizons()` for warping horizon thickness (inflate/deflate) + * `simulateColor()` adds multivariate simulation in CIELAB colorspace ## Incremental changes, should have no effect on previous code