add splitLogicErrors

R/checkHzDepthLogic.R

@@ -98,6 +98,11 @@ hzDepthTests <- function(top, bottom) {
   # bottom depth < top depth? or horizons not in top-depth order?
   test.1 <- any(bottom < top, na.rm = TRUE) | any(suppressWarnings(sort(top) != top))
 
+  if (is.na(test.1)) {
+    # test.1 is NA if test.3 is true for both top and bottom depth
+    test.1 <- TRUE
+  }
+
   # bottom depth == top depth
   test.2 <- any(top == bottom, na.rm = TRUE)
 
@@ -108,6 +113,7 @@ hzDepthTests <- function(top, bottom) {
   test.4 <- any(bottom[-n] != top[-1], na.rm = TRUE)
 
   res <- as.logical(c(test.1, test.2, test.3, test.4))
+
   names(res) <- c("depthLogic","sameDepth","missingDepth","overlapOrGap")
   return(res)
 }

R/splitLogicErrors.R

@@ -0,0 +1,65 @@
+#' Split a SoilProfileCollection into a list based on types of horizon logic errors
+#'
+#' Uses \code{checkHzDepthLogic} to identify presence of depth logic errors, same depths, missing depths, and overlaps/gaps between the horizons of each profile in a SoilProfileCollection.
+#' 
+#' @param object A SoilProfileCollection
+#' @param interact Calculate interaction between the four logic errors for groups? Default: \code{FALSE} always returns 4 groups, one for each logic error type.
+#' @param ... Additional arguments to \code{split.default}, called when \code{interact = TRUE}
+#'
+#' @return A named list of SoilProfileCollections (or \code{NULL}), with names: "depthLogic", "sameDepth", "missingDepth", "overlapOrGap". If \code{interact = TRUE} then the list elements groups determined by \code{interaction()} of the error types.
+#' @export
+#'
+#' @examples
+#' 
+#' data(sp4)
+#' depths(sp4) <- id ~ top + bottom
+#' 
+#' # no errors (all four list elements return NULL)
+#' splitLogicErrors(sp4)
+#' 
+#' # NA in top depth triggers depth logic and missing depth errors
+#' data(sp4)
+#' sp4$top[1] <- NA
+#' depths(sp4) <- id ~ top + bottom
+#' 
+#' splitLogicErrors(sp4)
+#' 
+#' # interact = TRUE gets errors for profile 1 in same group
+#' #  and allows you to pass extra arguments to split.default()
+#' splitLogicErrors(sp4, interact = TRUE, sep = "_", drop = TRUE)
+#' 
+splitLogicErrors <- function(object, interact = FALSE, ...) {
+
+  # do check logic on logic for each profile
+  f.logic <- checkHzDepthLogic(object)
+  logicNames <- c("depthLogic", "sameDepth", "missingDepth", "overlapOrGap")
+  names.idx <- match(logicNames, names(f.logic))
+
+  # reformat errors
+  f.errors <- do.call('rbind', apply(f.logic, 1, function(x) {
+    as.data.frame(t(ifelse(as.logical(x[names.idx]), logicNames, "")))
+  }))
+  f.errors[] <- lapply(f.errors, factor)
+  colnames(f.errors) <- logicNames
+
+  if (interact == TRUE) {
+    # interact == TRUE returns list elements based on interaction of f.errors
+    f.goodbad <- split.default(object, f = f.errors, ...)
+    f.goodbad <- lapply(f.goodbad, function(x) {
+                                      if (length(x) == 0)
+                                        return(NULL)
+                                      return(x)
+                                    })
+  } else {
+    # iterate over the four error types individually, ensuring no interaction
+    f.goodbad <- lapply(f.errors, function(x) {
+                                      res <- split(object, f = x)
+                                      if (length(res) == 2)
+                                        return(res[[2]])
+                                      return(NULL)
+                                    })
+  }
+
+  # return result as list of SPCs
+  return(f.goodbad)
+}

tests/testthat/test-checkHzDepthLogic.R

@@ -102,4 +102,27 @@ test_that("checkHzDepthLogic() overlap", {
   expect_false(res$valid[1])
 })
 
+test_that("splitLogicErrors", {
+  data(sp4)
+  depths(sp4) <- id ~ top + bottom
+
+  # no errors (all list elements return NULL)
+  expect_equal(unlist(splitLogicErrors(sp4)), c(NULL, NULL, NULL, NULL))
+
+  # NA in top depth triggers depth logic and missing depth errors
+  data(sp4)
+  sp4$top[1] <- NA
+  expect_message(depths(sp4) <- id ~ top + bottom)
+
+  res <- splitLogicErrors(sp4)
+
+  # the same profile occurs in two groups, since NA causes depth logic and missingDepth errors
+  expect_true(profile_id(res$depthLogic) == profile_id(res$missingDepth))
+
+  # interact = TRUE gets these in the same (interaction) group
+  #  each SPC profile occurs once, name/number elements varies with your data
+  #  (and whether or not you use split.default(..., drop = TRUE))
+  res2 <- splitLogicErrors(sp4, interact = TRUE, sep = "_", drop = TRUE)
+  expect_true(length(res2$depthLogic__missingDepth_) == 1)
+})