Fix compatibility with R <4.1/4.2

.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,16 +51,9 @@ 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, knitr=?ignore-before-r=4.0.0, rmarkdown=?ignore-before-r=4.0.0, testthat=?ignore-before-r=4.0.0,
           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
-          needs: check
 
       - name: Install soilDB from r-universe (R-devel only)
         if: matrix.config.r == 'devel'
@@ -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
 

R/allocate.R

@@ -747,20 +747,18 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
 
   # dissolve on pscs ----
   # calculate non-trimmed horizon thickness
-  x_dis <- x |>
-    hz_dissolve(by = "taxpartsize", idcol = "idcol", depthcols = c("top", "bot")) |>
-    transform(thk_o = bot - top)
+  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 <- x_dis |>
-    hz_intersect(y, idcol = "idcol", depthcols = c("top", "bot")) |>
-    transform(thk_t = bot - top)
+  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 <- hz_intersect(x, xy_dis, idcol = "idcol", depthcols = c("top", "bot")) |> suppressWarnings()
+  xy <- suppressWarnings(hz_intersect(x, xy_dis, idcol = "idcol", depthcols = c("top", "bot")))
   x_dis  <- NULL
   xy_dis <- NULL
 
@@ -790,8 +788,7 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
 
 
   # find adjacent horizons ----
-  xy_lag <- xy_agg |> 
-    hz_lag(idcol = "idcol", depthcols = c("top", "bot"))
+  xy_lag <- hz_lag(xy_agg, idcol = "idcol", depthcols = c("top", "bot"))
 
 
   # address special cases of strongly contrasting classes ----
@@ -801,8 +798,7 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
 
 
   # still needs special cases for very fine sand
-  xy_agg <- cbind(xy_agg, xy_lag) |> 
-    within({
+  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)
@@ -859,36 +855,32 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
   n_sc    <- NULL
   n_peiid <- NULL
 
-  test <- data.table::as.data.table(xy_agg)[, list(
+  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"
-  ] |>
-    as.data.frame()
+  ])
 
 
   # pick the sc pscs with the largest contrast or pscs with the greatest thickness
-  xy_res <- xy_agg |>
-    merge(test, by = "idcol", all.x = TRUE, sort = FALSE) |>
-    transform(
+  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 <- 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"
-    ] |>
-    as.data.frame() |>
-    within({
+  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)

R/segment.R

@@ -383,12 +383,8 @@ hz_dissolve <- function(object, by, idcol = "id", depthcols = c("top", "bottom")
 
 
   # append dissolve_id
-  n <- c(
-    var_dep$top, 
-    var_dep$bot
-    ) |>
-    nchar() |>
-    max(na.rm = TRUE)
+  n <- max(nchar(c(var_dep$top, var_dep$bot)), na.rm = TRUE)
+
   var_dep$dissolve_id <- paste0(
     var_dep$idcol,
     "_",
@@ -439,25 +435,20 @@ dissolve_hz <- function(object, by, id = "idcol", hztop = "top", hzbot = "bottom
 #' @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)
+#'   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)
 #' )
 #' 
-#' h |> hz_dissolve("by")
+#' hz_dissolve(h, "by")
 #' 
-#' h |> hz_dissolve("by") |> hz_intersect(x = _, y = h)
+#' hz_intersect(x = hz_dissolve(h, "by"), y = h)
 #' 
-#' h |> 
-#' hz_dissolve("by") |> 
-#' hz_intersect(x = h, y = _) |>
-#' aggregate(clay ~ dissolve_id, data = _, mean)
+#' 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 ----
@@ -502,9 +493,7 @@ hz_intersect <- function(x, y, idcol = "id", depthcols = c("top", "bottom")) {
 
     if (nrow(yi) > 0) {
 
-      int <- c(xi$top, xi$bot, yi$top, yi$bot) |>
-      sort() |>
-      unique()
+      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)
@@ -514,8 +503,8 @@ hz_intersect <- function(x, y, idcol = "id", depthcols = c("top", "bottom")) {
   }) ->.;
 
 
-  x_seg <- lapply(., function(x) x[["x_seg"]]) |> do.call("rbind", args = _)
-  y_seg <- lapply(., function(x) x[["y_seg"]]) |> do.call("rbind", args = _)
+  x_seg <- do.call("rbind", lapply(., function(x) x[["x_seg"]]))
+  y_seg <- do.call("rbind", lapply(., function(x) x[["y_seg"]]))
 
 
   xy_int <- merge(x_seg, y_seg, by = c("segment_id", "idcol", "top", "bot"), sort = FALSE)
@@ -559,22 +548,17 @@ hz_intersect <- function(x, y, idcol = "id", depthcols = c("top", "bottom")) {
 #' clay   = c(10, 12, 27, 35, 16)
 #' )
 #' 
-#' h |> hz_lag()
+#' hz_lag(h)
 #' 
-#' h |> hz_lag(-1)
+#' hz_lag(h, -1)
 #' 
-#' h |> hz_lag(10:15, unit = "depth")
+#' hz_lag(h, 10:15, unit = "depth")
 #' 
-#' h |> 
-#' hz_lag() |> 
-#' cbind(h, lag = _) |>
-#' transform(
-#' clay_dif = lag.clay_bot.1 - clay,
-#' texcl_contrast = paste0(texcl, "-", lag.texcl_bot.1))
+#' 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)
@@ -599,7 +583,7 @@ hz_lag <- function(object, lag = 1, unit = "index", idcol = "id", depthcols = c(
     x <- x[x$bot < 1000, ]
   }
 
-  test <- aggregate(top ~ idcol, data = x, length)$top |> max()
+  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")
@@ -639,46 +623,42 @@ hz_lag <- function(object, lag = 1, unit = "index", idcol = "id", depthcols = c(
     x_seg <- x_seg[1:(n + 1)]
 
 
-    x_seg <- lapply(lag, function(i) {
-
+    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, ]
+      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))
+      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) {
+    x_lag <- do.call("cbind", 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_lag <- .reset_inputs(x_lag, x_conversion)
 
-
   return(x_lag)
 }
 
@@ -747,4 +727,4 @@ hz_lag <- function(object, lag = 1, unit = "index", idcol = "id", depthcols = c(
 
   return(x)
 }
-
+

R/texture.R

@@ -1081,7 +1081,6 @@ fragvol_to_texmod <- 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", 
@@ -1100,7 +1099,7 @@ lookup_taxpartsize <- function() {
   names(test) <- .pscs_sc
 
   idx <- lapply(test, function(x) {
-    idx <- sapply(x, function(y) rank[which(fe == y)]) |> unlist()
+    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])
@@ -1132,5 +1131,4 @@ lookup_taxpartsize <- function() {
 }
 
 
-.pscs_sc <- 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") |> 
-  tolower()
+.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"))