Skip to content

Commit

Permalink
Merge pull request #317 from ncss-tech/r4compat
Browse files Browse the repository at this point in the history 
Fix compatibility with R <4.1/4.2
  • Loading branch information
@brownag
brownag authored Aug 3, 2024
2 parents b98383a + 085d4bd commit 23d4b2c
Show file tree
Hide file tree
Showing 7 changed files with 200 additions and 262 deletions.
20 changes: 10 additions & 10 deletions .github/workflows/R-CMD-check.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 }}
Expand All @@ -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'
Expand All @@ -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

157 changes: 73 additions & 84 deletions R/allocate.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
#'
Expand All @@ -718,7 +712,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)
Expand All @@ -728,7 +721,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)
Expand All @@ -738,7 +730,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]
Expand All @@ -749,26 +740,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
Expand All @@ -782,7 +774,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,
Expand All @@ -793,21 +785,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)
Expand Down Expand Up @@ -856,58 +845,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)
}
Loading

0 comments on commit 23d4b2c

Please sign in to comment.