Merge branch 'master' of https://github.com/ncss-tech/aqp

ncss-tech · Mar 12, 2024 · 91739e5 · 91739e5
2 parents f0843fb + fcad3e8
commit 91739e5
Show file tree

Hide file tree

Showing 4 changed files with 32 additions and 10 deletions.
diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml
@@ -36,7 +36,7 @@ jobs:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - uses: r-lib/actions/setup-r@v2
         with:

diff --git 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.")

diff --git a/R/estimatePSCS.R b/R/estimatePSCS.R
@@ -96,10 +96,13 @@ estimatePSCS = function(p, hzdesgn = "hzname", clay.attr = "clay",
   default_t <- rep(25, length(soildepth))
   default_b <- rep(100, length(soildepth))
 
+  odepth <- getMineralSoilSurfaceDepth(p, hzdesgn, simplify = FALSE)[[hz.depths[2]]]
+  ohzidx <- which(odepth > 0)
+
   # Key part A (soils with restriction in shallow depth)
-  lt36idx <- which(soildepth <= 36)
+  lt36idx <- which(soildepth - odepth <= 36)
   if (length(lt36idx) > 0) {
-    default_t[lt36idx] <- 0
+    default_t[lt36idx] <- 0 # O horizon correction applied below
     default_b[lt36idx] <- soildepth[lt36idx]
     shallow_flag[lt36idx] <- TRUE
   }
@@ -115,8 +118,6 @@ estimatePSCS = function(p, hzdesgn = "hzname", clay.attr = "clay",
   }
 
   # Adjust PSCS range downward if organic soil material is present at surface (i.e. mineral soil surface depth > 0)
-  odepth <- getMineralSoilSurfaceDepth(p, hzdesgn, simplify = FALSE)[[hz.depths[2]]]
-  ohzidx <- which(odepth > 0)
   if (length(ohzidx) > 0) {
 
     default_t[ohzidx] <- default_t[ohzidx] + odepth[ohzidx]

diff --git a/tests/testthat/test-estimatePSCS.R b/tests/testthat/test-estimatePSCS.R
@@ -6,10 +6,22 @@ data(sp1, package = 'aqp')
 depths(sp1) <- id ~ top + bottom
 site(sp1) <- ~ group
 
-p <- sp1[1]
+p <- sp1[1,]
 attr <- 'prop' # clay contents %
 
-q <- sp1[2]
+q <- sp1[2,]
+
+x <- data.frame(
+  peiid = 706300,
+  taxsubgrp = "Lithic Humicryods",
+  top = c(0, 13, 16, 18, 24, 40),
+  bottom = c(13, 16, 18, 24, 40, 65),
+  name = c("Oi", "A", "E", "Bhs", "2C", "2R"),
+  texture = c("SPM", "SIL", "SIL", "SIL", "SIL", "BR"),
+  prop = c(0, 6, 6, 6, 6, 6)
+)
+depths(x) <- peiid ~ top + bottom
+site(x) <- ~ taxsubgrp
 
 test_that("estimatePSCS()", {
 
@@ -64,6 +76,14 @@ test_that("estimatePSCS()", {
   expect_error(estimatePSCS(q2, clay.attr = 'prop', texcl.attr = "texture", hzdesgn = 'foo'))
 })
 
+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'),
+               data.frame(id = c("706300", "P002"), 
+                          pscs_top = c(13, 30),
+                          pscs_bottom = c(40, 59)))
+})
+
 test_that("estimatePSCS() multiple profiles",{
   e <- estimatePSCS(sp1, clay.attr = 'prop', texcl.attr = "texture", hzdesgn = 'name')
   expect_equal(e$pscs_top, c(49, 30, 2, 32, 5, 31, 25, 27, 28))