diff --git a/NAMESPACE b/NAMESPACE index a02ae869..aba430db 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -101,7 +101,7 @@ export(hz_lag) export(hz_segment) export(hz_to_taxpartsize) export(invertLabelColor) -export(lookup_PSCS) +export(lookup_taxpartsize) export(lunique) export(maxDepthOf) export(minDepthOf) diff --git a/R/allocate.R b/R/allocate.R index 9a43ad2a..037b8305 100644 --- a/R/allocate.R +++ b/R/allocate.R @@ -659,7 +659,7 @@ allocate <- function(..., to = c("FAO Salt Severity", "FAO Black Soil", "ST Diag #' #' @author Stephen Roecker #' -#' @seealso [texture_to_taxpartsize()], [lookup_PSCS()] +#' @seealso [texture_to_taxpartsize()], [lookup_taxpartsize()] #' #' @export diff --git a/R/texture.R b/R/texture.R index 2b5387a0..70330a8f 100644 --- a/R/texture.R +++ b/R/texture.R @@ -427,7 +427,7 @@ texmod_to_fragvoltot <- function(texmod = NULL, lieutex = NULL) { #' #' @return - `texture_to_taxpartsize`: a character vector containing `"taxpartsize"` classes #' -#' @seealso \code{\link{hz_to_taxpartsize}} +#' @seealso [hz_to_taxpartsize()], [lookup_taxpartsize()] #' #' @rdname texture #' @@ -1071,7 +1071,7 @@ fragvol_to_texmod <- function( #' @examples #' #' # class codes -#' lu <- lookup_PSCS() +#' lu <- lookup_taxpartsize() #' #' idx <- lu$contrasting == FALSE #' @@ -1080,18 +1080,18 @@ fragvol_to_texmod <- function( #' lu$rank[as.integer(lu$taxpartsize)[idx]] #' -lookup_PSCS <- function() { +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", "pumiceous", "clayey-skeletal", - "hydrous-skeletal", "medial-skeletal", "loamy-skeletal", "gypseous-skeletal", - "ashy-skeletal", "sandy-skeletal", "cindery", "fragmental") + "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, -97.33, -43.33, -55.96, - -76, -83.23, -83.35, -93.5, -95.33, -97.33, -96.94) + 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") diff --git a/man/hz_to_taxpartsize.Rd b/man/hz_to_taxpartsize.Rd index f850ed3c..2daefdf8 100644 --- a/man/hz_to_taxpartsize.Rd +++ b/man/hz_to_taxpartsize.Rd @@ -77,7 +77,7 @@ hz_to_taxpartsize(horizons(h), pscs) } \seealso{ -\code{\link[=texture_to_taxpartsize]{texture_to_taxpartsize()}}, \code{\link[=lookup_PSCS]{lookup_PSCS()}} +\code{\link[=texture_to_taxpartsize]{texture_to_taxpartsize()}}, \code{\link[=lookup_taxpartsize]{lookup_taxpartsize()}} } \author{ Stephen Roecker diff --git a/man/lookup_PSCS.Rd b/man/lookup_taxpartsize.Rd similarity index 90% rename from man/lookup_PSCS.Rd rename to man/lookup_taxpartsize.Rd index 373e2748..117516b4 100644 --- a/man/lookup_PSCS.Rd +++ b/man/lookup_taxpartsize.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/texture.R -\name{lookup_PSCS} -\alias{lookup_PSCS} +\name{lookup_taxpartsize} +\alias{lookup_taxpartsize} \title{Ranking Systems for USDA Taxonomic Particle-Size and Substitute Classes of Mineral Soils} \usage{ -lookup_PSCS() +lookup_taxpartsize() } \value{ A data.frame with a rank column, taxonomic family particle size class, and a flag for contrasting. @@ -15,7 +15,7 @@ Generate a lookup table of USDA Particle-Size and Substitute Classes names, ran \examples{ # class codes -lu <- lookup_PSCS() +lu <- lookup_taxpartsize() idx <- lu$contrasting == FALSE diff --git a/man/texture.Rd b/man/texture.Rd index 83137c03..06777da1 100644 --- a/man/texture.Rd +++ b/man/texture.Rd @@ -281,7 +281,7 @@ Matthew R. Levi, Modified Centroid for Estimating Sand, Silt, and Clay from Soil \seealso{ \code{\link{SoilTextureLevels}} -\code{\link{hz_to_taxpartsize}} +\code{\link[=hz_to_taxpartsize]{hz_to_taxpartsize()}}, \code{\link[=lookup_taxpartsize]{lookup_taxpartsize()}} } \author{ Stephen Roecker diff --git a/misc/sandbox/psc_rank.R b/misc/sandbox/psc_rank.R new file mode 100644 index 00000000..41078695 --- /dev/null +++ b/misc/sandbox/psc_rank.R @@ -0,0 +1,326 @@ + +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, ash) ~ psc, + data = psc, + function(x) round(mean(x, na.rm = TRUE), 2) + ) + + +# special classess ---- +clayey <- psc |> + subset(psc %in% c("fine", "very-fine")) |> + within({psc = "clayey"}) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) + +loamy <- psc |> + subset(psc %in% c("coarse-loamy", "fine-loamy")) |> + within({psc = "loamy"}) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) + + +## ashy ---- +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), 2) + }) + +ashy_pu <- ashy_sk |> + within({ + psc = "ashy-pumiceous" + # sand = sand - 1 + # silt = silt + 0.9 + # clay = clay + 0.1 + frags = round(frags * 2/3, 2) + }) + + +cindery <- psc |> + subset(psc %in% c("sandy")) |> + within({ + psc = "cindery" + sand = sand - 59 + silt = silt + 60 + clay = clay - 1 + ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) |> + within({ + frags = round(mean(60:89), 2) + }) + + +pumiceous <- cindery |> + within({ + psc = "pumiceous" + sand = sand - 1 + silt = silt + 0.5 + clay = clay + 0.5 + # frags = round(frags * 2/3, 2) + }) + + +## medial ---- +medial <- psc |> + subset(psc %in% c("fine-silty")) |> + within({ + psc = "medial" + 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) + ) + + +medial_sk <- medial |> + within({ + psc = "medial-skeletal" + frags = round(mean(35:89), 2) + }) + +medial_pu <- medial_sk |> + within({ + psc = "medial-pumiceous" + frags = round(frags * 2/3, 2) + }) + + +## hydrous ---- +hydrous <- psc |> + subset(psc %in% c("fine")) |> + within({ + psc = "hydrous" + sand = sand - 18 + silt = silt + 20 + clay = clay - 2 + ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) + + +hydrous_sk <- hydrous |> + within({ + psc = "hydrous-skeletal" + frags = round(mean(35:89), 2) + }) + +hydrous_pu <- hydrous_sk |> + within({ + psc = "hydrous-pumiceous" + frags = round(frags * 2/3, 2) + }) + + + +## diatomaceous ---- +diatomaceous <- psc |> + subset(psc == "very-fine") |> + within({ + psc = "diatomaceous" + clay = clay + 10 + sand = sand - 5 + silt = silt - 5 + }) + + +## gypseous ---- +co_gypseous <- psc |> + subset(psc %in% c("coarse-silty")) |> + within({ + psc = "coarse-gypseous" + sand = sand + 40 + silt = silt - 39 + clay = clay - 1 + ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) + + +fi_gypseous <- psc |> + subset(psc %in% c("fine-silty")) |> + within({ + psc = "fine-gypseous" + sand = sand + 40 + silt = silt - 39.8 + clay = clay - 0.2 + ash = 60 + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) + + +gypseous_sk <- rbind(fi_gypseous, co_gypseous) |> + within({ + psc = "gypseous-skeletal" + frags = round(mean(35:89), 2) + }) |> + aggregate( + cbind(sand, silt, clay, frags, ash) ~ psc, + data = _, + function(x) round(mean(x), 2) + ) + + +# 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 + ) +psc0 <- do.call("rbind", psc_l) +psc0 <- psc0[order(psc0$frags, - psc0$clay), ] +row.names(psc0) <- NULL +# rm(list = names(psc_l)[[-1]]) + +psc <- psc[order(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] + + + + + + +