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

@@ -662,38 +662,32 @@ allocate <- function(..., to = c("FAO Salt Severity", "FAO Black Soil", "ST Diag
 #' @seealso [texture_to_taxpartsize()], [lookup_taxpartsize()]
 #' 
 #' @export
-
 #' @examples
 #' 
 #' h <- data.frame(
-#' id = 1,
-#' hzname = c("A", "BA", "Bw", "BC", "C"),
-#' top    = c( 0, 10, 45, 60,  90),
-#' bottom = c(10, 45, 60, 90, 150),
-#' clay   = c(15, 16, 45, 20,  10),
-#' sand   = c(10, 35, 40, 50,  90),
-#' frags  = c( 0,  5, 10, 38,  40)
-#' )
-#'
-#' h <- cbind(
-#' h, 
-#' texcl = ssc_to_texcl(clay = h$clay, sand = h$sand)
+#'   id = 1,
+#'   hzname = c("A", "BA", "Bw", "BC", "C"),
+#'   top    = c(0, 10, 45, 60,  90),
+#'   bottom = c(10, 45, 60, 90, 150),
+#'   clay   = c(15, 16, 45, 20,  10),
+#'   sand   = c(10, 35, 40, 50,  90),
+#'   frags  = c(0,  5, 10, 38,  40)
 #' )
 #' 
-#' pscs <- data.frame(
-#' id = 1, 
-#' top = 25, 
-#' bottom = 100
-#' )
+#' h <- cbind(h,
+#'            texcl = ssc_to_texcl(clay = h$clay, sand = h$sand))
+#' 
+#' pscs <- data.frame(id = 1,
+#'                    top = 25,
+#'                    bottom = 100)
 #' 
-#' h <- cbind(
-#' h, 
-#' taxpartsize = texture_to_taxpartsize(
-#' texcl = h$texcl,
-#' clay  = h$clay, 
-#' sand  = h$sand,
-#' fragvoltot = h$frags
-#' ))
+#' h <- cbind(h,
+#'            taxpartsize = texture_to_taxpartsize(
+#'              texcl = h$texcl,
+#'              clay  = h$clay,
+#'              sand  = h$sand,
+#'              fragvoltot = h$frags
+#'            ))
 #' 
 #' depths(h) <- id ~ top + bottom
 #' 
@@ -713,7 +707,6 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
   # xy <- hz_intersect(x, y, idcol = idcol, depthcols = depthcols)
   # x_sub <- x[x$rn %in% xy$rn, ]
 
-
   # check segment_id ----
   ## if it exists, overwrite it
   x_nm <- names(x)
@@ -723,7 +716,6 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
     y[y_nm == "segment_id"] <- NULL
   }
 
-
   # check dissolve_id ----
   ## if it exists, overwrite it
   x_nm <- names(x)
@@ -733,7 +725,6 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
     y[y_nm == "dissolve_id"] <- NULL
   }
 
-
   # standardize inputs ----
   vars <- c(idcol, depthcols, clay, taxpartsize)
   x <- x[vars]
@@ -744,26 +735,27 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
   y <- y[c(idcol, depthcols)]
   y <- .standardize_inputs(y, idcol = idcol, depthcols = depthcols)$x
 
-
   # 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
-
 
   # aggregate clay values within dissolved pscs ----
   top       <- NULL
@@ -777,7 +769,7 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
     list(
       top       = min(top,                          na.rm = TRUE),
       bot       = max(bot,                          na.rm = TRUE),
-      clay_wt   = weighted.mean(clay,   w = thk_t,  na.rm = TRUE),
+      clay_wt   = weighted.mean(clay,   w = thk_t,  na.rm = TRUE), 
       # sandvf_wt = weighted.mean(sandvf, w = thk_t,  na.rm = TRUE),
       # need to impute frags
       # frag_wt = weighted.mean(total_frags_pct_nopf, w = thk_t), na.rm = TRUE,
@@ -788,21 +780,18 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
   data.table::setorder(xy_agg, idcol, top)
   xy_agg <- as.data.frame(xy_agg)
 
-
   # 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 ----
   clay_wt_bot.1     <- NULL
   sandvf_wt_bot.1   <- NULL
   taxpartsize_bot.1 <- NULL
 
-
   # 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)
@@ -851,58 +840,58 @@ hz_to_taxpartsize <- function(x, y, taxpartsize = "taxpartsize", clay = "clay",
       # )
       # idx_sc = grepl("over", sc)
       sc = ifelse(idx_sc, sc, taxpartsize)
-    })
+    }
+  )
   xy_lag <- NULL
 
-
   # find multiple strongly contrasting ps classes within the control section
   n_sc    <- NULL
   n_peiid <- NULL
 
-  test <- 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()
-
+  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"])
 
   # 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({
-      # 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)
-      pscs1 = NULL
-      pscs2 = NULL
-      pscs3 = NULL
-      pscs4 = NULL
-      pscs5 = NULL
-    })
-
+  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)
+        pscs1 = NULL
+        pscs2 = NULL
+        pscs3 = NULL
+        pscs4 = NULL
+        pscs5 = NULL
+      })
 
   # reset inputs
   xy_res <- .reset_inputs(xy_res, x_conv[1])
 
-
   return(xy_res)
 }