From c4d37e9280e5131d7bd755b7f36b3c6649cf9f32 Mon Sep 17 00:00:00 2001
From: Stephen Roecker <stephen.roecker@gmail.com>
Date: Wed, 22 May 2024 16:54:34 -0500
Subject: [PATCH] update hz_lag()

---
 R/segment.R   | 98 ++++++++++++++++++++++++++++++++++++++++-----------
 man/hz_lag.Rd | 14 +++++---
 2 files changed, 86 insertions(+), 26 deletions(-)

diff --git a/R/segment.R b/R/segment.R
index b70530de..4dc7a096 100644
--- a/R/segment.R
+++ b/R/segment.R
@@ -534,8 +534,8 @@ hz_intersect <- function(x, y, idcol = "id", depthcols = c("top", "bottom")) {
 #' @description This function finds adjacent values to a horizon values at lagged distances.
 #'
 #' @param object a \code{data.frame}
-#' @param vars character: column names, to lag.
 #' @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 #'
@@ -560,21 +560,25 @@ hz_intersect <- function(x, y, idcol = "id", depthcols = c("top", "bottom")) {
 #' 
 #' h |> hz_lag()
 #' 
+#' h |> hz_lag(-1)
+#' 
+#' h |> hz_lag(10:15, unit = "depth")
+#' 
 #' h |> 
 #' hz_lag() |> 
-#' cbind(h) |>
+#' cbind(h, lag = _) |>
 #' transform(
-#' clay_dif = clay - clay_lag.1,
-#' texcl_contrast = paste0(texcl, "-", texcl_lag.1))
+#' clay_dif = lag.clay_bot.1 - clay,
+#' texcl_contrast = paste0(texcl, "-", lag.texcl_bot.1))
 #' 
 
 
 
-hz_lag <- function(object, lag = 1, vars = NULL, idcol = "id", depthcols = c("top", "bottom"), order = FALSE) {
+hz_lag <- function(object, lag = 1, unit = "index", idcol = "id", depthcols = c("top", "bottom"), order = FALSE) {
   
   nm <- names(object)
-  idx <- which(! nm %in% c(idcol, depthcols))
-  if (is.null(vars)) vars <- nm[idx]
+  idx_std <- which(! nm %in% c(idcol, depthcols))
+  vars <- nm[idx_std]
   
   
   # check arguments ----
@@ -586,6 +590,20 @@ hz_lag <- function(object, lag = 1, vars = NULL, idcol = "id", depthcols = c("to
   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 <- aggregate(top ~ idcol, data = x, length)$top |> max()
+  if (unit == "index") {
+    if ((test - 1) < max(lag)) {
+    stop("lag can not be greater than the maximum number of horizons")
+    }
+  }
   
   
   # order ----
@@ -595,31 +613,69 @@ hz_lag <- function(object, lag = 1, vars = NULL, idcol = "id", depthcols = c("to
   
   
   # lag ----
-  .lag <- function(x, lag = lag, vars = NULL) {
+  .lag_ind <- function(x, lag = lag) {
     
     nr  <- nrow(x)
     top <- 1:nr
-    bot <- c((1 + lag):nr, rep(NA, lag))
+    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_deps  <- x$bot[top]   == x$top[bot]
-    # lag_vars <- ifelse(
-    #   test_idcol & !is.na(test_idcol),
-    #   x[bot, var],
-    #   NA)
     lag_vars <- x[test_idcol * bot, vars]
-    names(lag_vars) <- paste0(vars, "_lag.", lag)
-    
+    if (lag >= 0) names(lag_vars) <- paste0(vars, "_bot.",     lag)
+    if (lag <  0) names(lag_vars) <- paste0(vars, "_top.", abs(lag))
+
     return(lag_vars)
   }
   
-  # x_lag <- lapply(vars, function(y) .lag(x, lag = lag, y)) |>
-  #   do.call("data.frame", args = _)
-  # names(x_lag) <- paste0(vars, "_lag.", lag)
-  x_lag <- .lag(x, lag, vars)
+  
+  .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 <- 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)
+    }) |>
+      do.call("cbind", args = _)
+    
+    return(x_seg)
+  }
+  
+  
+  if (unit == "index") {
+    x_lag <- lapply(lag, function(i) {
+      .lag_ind(x, i)
+    }) |>
+      do.call("cbind", args = _)
+    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 <- .reset_inputs(cbind(x, x_lag), x_conversion)
+  x <- .reset_inputs(cbind(x, x_lag), x_conversion)
+  
    
   return(x_lag)
 }
diff --git a/man/hz_lag.Rd b/man/hz_lag.Rd
index f234da02..2a5f32df 100644
--- a/man/hz_lag.Rd
+++ b/man/hz_lag.Rd
@@ -7,7 +7,7 @@
 hz_lag(
   object,
   lag = 1,
-  vars = NULL,
+  unit = "index",
   idcol = "id",
   depthcols = c("top", "bottom"),
   order = FALSE
@@ -18,7 +18,7 @@ hz_lag(
 
 \item{lag}{integer: number of horizons to lag}
 
-\item{vars}{character: column names, to lag.}
+\item{unit}{character: lag units in index or depth.}
 
 \item{idcol}{character: column name of the pedon ID within the object.}
 
@@ -47,12 +47,16 @@ clay   = c(10, 12, 27, 35, 16)
 
 h |> hz_lag()
 
+h |> hz_lag(-1)
+
+h |> hz_lag(10:15, unit = "depth")
+
 h |> 
 hz_lag() |> 
-cbind(h) |>
+cbind(h, lag = _) |>
 transform(
-clay_dif = clay - clay_lag.1,
-texcl_contrast = paste0(texcl, "-", texcl_lag.1))
+clay_dif = lag.clay_bot.1 - clay,
+texcl_contrast = paste0(texcl, "-", lag.texcl_bot.1))
 
 }
 \author{