diff --git a/DESCRIPTION b/DESCRIPTION index a010557..6b8a675 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,10 +3,7 @@ Type: Package Title: Estimate soil properties via pedotransferfunctions Version: 0.5.0.9000 Authors@R: c(person(given = "Gerard", family = "Ros", email = "gerard.ros@nmi-agro.nl", role = c("aut","cre")), - person(given = "Kees", family = "van den Dool", email = "kees.vandendool@nmi-agro.nl", role = c("aut")), - person(given = "Sven", family = "Verweij", email = "sven.verweij@nmi-agro.nl", role = c("aut")), person(given = "Yuki", family = "Fujita", email = "yuki.fujita@nmi-agro.nl", role = c("aut")), - person(given = "Tessa", family = "van der Voort", email = "tessa.vandervoort@nmi-agro.nl", role = c("aut")), person(given = "Job", family = "de Pater", email = "job.depater@nmi-agro.nl", role = c("aut")), person(given = "Brent", family = "Riechelman", email = "brent.riechelman@nmi-agro.nl", role = c("aut")), person("Nutriënten Management Instituut", email = "nmi@nmi-agro.nl", role = "cph")) @@ -24,6 +21,9 @@ Suggests: rmarkdown, knitr, ggplot2, + roxygen2, + devtools, testthat (>= 3.0.0) VignetteBuilder: knitr Config/testthat/edition: 3 + diff --git a/NEWS.md b/NEWS.md index 0595efa..315e95e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -74,12 +74,16 @@ * functions to facilitate checkmates with `sptf_parameters` (`check_enum()`, `check_numeric`, `get_minval()`, `get_maxval()`, `enum_opts()`) * manuals for whc and pmn functions +* add unit tests for all separate functions + ## Changed * checkmates to use `sptf_parameters` instead of hardcoding min and maxvalues in each function * export whc and pmn ptf's in NAMESPACE * `sptf_whc4` and `sptf_whc7` now takes A_DEPTH in m instead of cm +* removed the `euptf` dependency +* removed the wilting point as function input parameter ## Version 0.1.0 2022-08-15 diff --git a/R/whc.R b/R/whc.R index 642ce89..ab759ca 100644 --- a/R/whc.R +++ b/R/whc.R @@ -15,10 +15,10 @@ sptf_whc1 <- function(A_C_OF, A_SAND_MI, A_CLAY_MI) { theta_pwp = theta_fc = NULL # Check input - arg.length <-max(length(A_C_OF), length(A_SAND_MI), length(A_CLAY_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) + arg.length <- max(length(A_C_OF), length(A_SAND_MI), length(A_CLAY_MI)) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) # Collect data into a table (set in units %) dt <- data.table(A_C_OF = A_C_OF * 0.1, @@ -50,6 +50,11 @@ sptf_whc1 <- function(A_C_OF, A_SAND_MI, A_CLAY_MI) { #' #' @export sptf_whc2 <- function(A_C_OF, A_SAND_MI, A_CLAY_MI) { + # Check input + arg.length <- max(length(A_C_OF), length(A_SAND_MI), length(A_CLAY_MI)) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) # add visual bindings theta_wp = theta_fc = NULL @@ -92,7 +97,12 @@ sptf_whc2 <- function(A_C_OF, A_SAND_MI, A_CLAY_MI) { #' @references Saxton et al.(1986) Estimating Generalized Soil-water Characteristics from Texture #' #' @export -sptf_whc3 <- function(A_SAND_MI,A_CLAY_MI) { +sptf_whc3 <- function(A_SAND_MI, A_CLAY_MI, mp_fc = 33) { + # Check input + arg.length <- max(length(A_SAND_MI), length(A_CLAY_MI)) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + checkmate::assert_true(mp_fc > 10) # Add visual bindings theta = theta_sat = theta_res = theta_fc = alfa = n = A = B = theta_wp =NULL @@ -110,6 +120,9 @@ sptf_whc3 <- function(A_SAND_MI,A_CLAY_MI) { A_CLAY_MI = A_CLAY_MI, value = NA_real_) + # wilting point + mp_wp = 1500 + # Calculate parameter values dt[, A := 100 * exp(-4.396 - 0.0715 * A_CLAY_MI - 0.000488 * A_SAND_MI ^ 2 - 0.00004285 * A_SAND_MI ^ 2 * A_CLAY_MI)] dt[, B := -3.140 - 0.00222 * A_CLAY_MI ^ 2 - 0.00003484 * A_SAND_MI ^ 2 * A_CLAY_MI] @@ -132,14 +145,13 @@ sptf_whc3 <- function(A_SAND_MI,A_CLAY_MI) { #' @import data.table #' #' @details -#' For this function A_DEPTH should be between 0.08 and 0.18 +#' For this function, A_DEPTH should be between 0.08 and 1.8 m #' #' #' @references Oosterveld and Chang (1980) Empirical relations between laboratory determinations of soil texture and moisture retention #' #' @export -sptf_whc4 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { - +sptf_whc4 <- function(A_C_OF, A_CLAY_MI, A_SAND_MI) { # Add visual bindings theta_sat = theta_res = theta_fc = alfa = n = theta_wp = mp_fc = NULL @@ -149,10 +161,10 @@ sptf_whc4 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_DEPTH, lower = 0.08, upper = 0.180) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + checkmate::assert_numeric(A_DEPTH, lower = 0.08, upper = 1.80) # Collect data into a table (set in units %, depth in cm) dt <- data.table(A_C_OF = A_C_OF, @@ -172,7 +184,6 @@ sptf_whc4 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { # return value return(value) - } @@ -198,11 +209,11 @@ sptf_whc5 <- function(A_SOM_LOI, A_CLAY_MI, A_SILT_MI) { mp_whc = 0 # Check input - arg.length <-max(length(A_SOM_LOI), length(A_CLAY_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_SOM_LOI, lower = 0, upper = 100,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) - + arg.length <- max(length(A_SILT_MI), length(A_CLAY_MI), length(A_SOM_LOI)) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SOM_LOI', A_SOM_LOI, FALSE, arg.length) + # Collect data into a table (set in units %) dt <- data.table(A_SILT_MI = A_SILT_MI, A_CLAY_MI = A_CLAY_MI, @@ -211,6 +222,9 @@ sptf_whc5 <- function(A_SOM_LOI, A_CLAY_MI, A_SILT_MI) { topsoil = topsoil, value = NA_real_ ) + # wilting point + mp_wp = 1500 + # add density (g / cm3) dt[,D_BDS := (1617 - 77.4 * log(A_C_OF) - 3.49 * A_C_OF)*0.001] @@ -221,7 +235,7 @@ sptf_whc5 <- function(A_SOM_LOI, A_CLAY_MI, A_SILT_MI) { - 0.0000733 * A_SOM_LOI * A_CLAY_MI - 0.000619 * D_BDS * A_CLAY_MI - 0.001183 * D_BDS * A_SOM_LOI - 0.0001664 * topsoil * A_SILT_MI] - dt[, alfa := exp( + dt[, alfa := exp( -14.96 + 0.03135 * A_CLAY_MI + 0.0351 * A_SILT_MI + 0.646 * A_SOM_LOI + 15.29 * D_BDS - 0.192 * topsoil - 4.671 * D_BDS ^ 2 - 0.000781 * A_CLAY_MI ^ 2 - 0.00687 * A_SOM_LOI ^ 2 + 0.0449 / A_SOM_LOI + 0.0663 * log(A_SILT_MI) @@ -229,7 +243,7 @@ sptf_whc5 <- function(A_SOM_LOI, A_CLAY_MI, A_SILT_MI) { + 0.00673 * topsoil * A_CLAY_MI )] - dt[, n := 1 + exp( + dt[, n := 1 + exp( -25.23 - 0.02195 * A_CLAY_MI + 0.0074 * A_SILT_MI - 0.1940 * A_SOM_LOI + 45.5 * D_BDS - 7.24 * D_BDS ^ 2 + 0.0003658 * A_CLAY_MI ^ 2 + 0.002885 * A_SOM_LOI ^ 2 - 12.81 / D_BDS - 0.1524 / A_SILT_MI - 0.01958 / A_SOM_LOI @@ -274,9 +288,9 @@ sptf_whc6 <- function(A_C_OF,A_CLAY_MI, A_SAND_MI) { # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) # Collect data into a table (set in units %) dt <- data.table(A_SAND_MI = A_SAND_MI, @@ -284,7 +298,7 @@ sptf_whc6 <- function(A_C_OF,A_CLAY_MI, A_SAND_MI) { A_C_OF = A_C_OF * 0.1, value = NA_real_ ) - + # add density dt[,D_BDS := (1617 - 77.4 * log(A_C_OF * 10) - 3.49 * A_C_OF * 10)*0.001] @@ -292,6 +306,7 @@ sptf_whc6 <- function(A_C_OF,A_CLAY_MI, A_SAND_MI) { dt[, theta_sat := 0.81 - 0.283 * D_BDS + 0.001 * A_CLAY_MI] dt[, theta_res := 0.015 + 0.005 * A_CLAY_MI + 0.014 * A_C_OF] dt[, alfa := exp(-2.486 + 0.025 * A_SAND_MI - 0.351 * A_C_OF - 2.617 * D_BDS - 0.023 * A_CLAY_MI)] + dt[, n := exp(0.053 - 0.009 * A_SAND_MI - 0.013 * A_CLAY_MI + 0.00015 * A_SAND_MI ^ 2)] dt[, n := exp(0.053 - 0.009 * A_SAND_MI - 0.013 * A_CLAY_MI + 0.00015 * A_SAND_MI^2)] # Calculate volumetric water content at field capacity (cm3/cm3) and wilting point @@ -331,12 +346,12 @@ sptf_whc7 <-function(A_C_OF,A_CLAY_MI,A_SILT_MI, A_SAND_MI) { mp_fc = 33 # Check input - arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SAND_MI),length(A_SILT_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) - + arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SILT_MI),length(A_SAND_MI)) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + # Collect data into a table (set in units %, and depth in cm) dt <- data.table(A_C_OF = A_C_OF * 0.1, A_CLAY_MI = A_CLAY_MI, @@ -422,9 +437,9 @@ sptf_whc8 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) # Collect data into a table (set in units %) dt <- data.table(A_SAND_MI = A_SAND_MI, @@ -433,7 +448,7 @@ sptf_whc8 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { value = NA_real_ ) - # add density (with Corg in g/kg as input) as g/cm3 + # add density (with Corg in g/kg as input) as g/cm3 dt[,D_BDS := (1617 - 77.4 * log(A_C_OF * 10) - 3.49 * A_C_OF * 10) * 0.001] # Calculate water retention parameters @@ -476,9 +491,9 @@ sptf_whc9 <- function(A_C_OF,A_CLAY_MI, A_SILT_MI) { # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SILT_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) checkmate::assert_subset(mp_fc, choices = c(10, 33), empty.ok = FALSE) # Collect data into a table (set in units %) @@ -515,7 +530,6 @@ sptf_whc9 <- function(A_C_OF,A_CLAY_MI, A_SILT_MI) { #' #' @export sptf_whc10 <-function(A_C_OF,A_CLAY_MI,A_SILT_MI,A_SAND_MI) { - # add visual bindings mp = theta_wp = a = b = d = e = f = theta_fc = theta_wp = NULL D_BDS = A_SOM_LOI = NULL @@ -525,10 +539,10 @@ sptf_whc10 <-function(A_C_OF,A_CLAY_MI,A_SILT_MI,A_SAND_MI) { # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SILT_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) checkmate::assert_subset(mp_fc, choices = c(10, 33), empty.ok = FALSE) # Collect data into a table (set in units %) @@ -569,7 +583,6 @@ sptf_whc10 <-function(A_C_OF,A_CLAY_MI,A_SILT_MI,A_SAND_MI) { #' #' @export sptf_whc11 <- function(A_C_OF,A_CLAY_MI,A_SILT_MI) { - # add visual bindings theta_sat = theta_res = theta_fc = alfa = n = d_g = sigma_g = psi_es = lambda = psi_b= theta_wp = NULL D_BDS = NULL @@ -579,9 +592,9 @@ sptf_whc11 <- function(A_C_OF,A_CLAY_MI,A_SILT_MI) { # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SILT_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) checkmate::assert_numeric(mp_whc, any.missing = FALSE) # Collect data into a table @@ -633,10 +646,10 @@ sptf_whc12 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { mp_wp = 4.2 # Check input - arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) + arg.length <- max(length(A_C_OF), length(A_CLAY_MI), length(A_SAND_MI)) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) checkmate::assert_numeric(mp_wp, any.missing = FALSE) checkmate::assert_subset(mp_fc, choices = c(2, 4.2)) @@ -672,16 +685,16 @@ sptf_whc12 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { #' #' @export sptf_whc13 <- function(A_C_OF,A_CLAY_MI,A_SAND_MI) { - + # Add visual bindings theta_sat = theta_res = theta_fc = alfa = n = A_LOAM_MI = Dichtheid = theta_wp = NULL D_BDS = NULL # Check input arg.length <-max(length(A_C_OF), length(A_CLAY_MI),length(A_SAND_MI)) - checkmate::assert_numeric(A_C_OF, lower = 0, upper = 1000,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_C_OF', A_C_OF, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) # Collect data into a table (set in units %) dt <- data.table(A_C_OF = A_C_OF * 0.1, @@ -725,10 +738,15 @@ sptf_whc14 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { mp_wp = 4.2 # Check input - arg.length <-max(length(A_SOM_LOI), length(A_CLAY_MI),length(A_SILT_MI)) - checkmate::assert_numeric(A_SOM_LOI, lower = 0, upper = 100,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) + arg.length <- + max( + length(A_CLAY_MI), + length(A_SILT_MI), + length(A_SOM_LOI) + ) + check_numeric('A_SOM_LOI', A_SOM_LOI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) checkmate::assert_numeric(mp_fc, any.missing = FALSE) checkmate::assert_numeric(mp_wp, any.missing = FALSE) @@ -741,6 +759,9 @@ sptf_whc14 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { A_LOAM_MI = (A_CLAY_MI + A_SILT_MI), value = NA_real_ ) + # wilting point + mp_wp = 1500 + # For sandy soils dt[A_CLAY_MI < 8, Dichtheid := 1 / ( -1.984 + 0.01841 * A_SOM_LOI + 0.032 * topsoil + 0.00003576 * A_LOAM_MI ^ 2 + @@ -803,11 +824,10 @@ sptf_whc15 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { # Check input arg.length <-max(length(A_SOM_LOI), length(A_CLAY_MI),length(A_SILT_MI)) - checkmate::assert_numeric(A_SOM_LOI, lower = 0, upper = 100,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_SOM_LOI', A_SOM_LOI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) checkmate::assert_numeric(mp_fc, any.missing = FALSE) - checkmate::assert_numeric(mp_wp, any.missing = FALSE) # Collect data into a table, with loam content (< 50 um) dt <- data.table(A_CLAY_MI = A_CLAY_MI, @@ -817,7 +837,7 @@ sptf_whc15 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { A_LOAM_MI = (A_CLAY_MI + A_SILT_MI), value = NA_real_ ) - + # For sandy soils dt[A_CLAY_MI < 8, Dichtheid := 1 / ( -7.58 + 0.01791 * A_SOM_LOI + 0.0326 * topsoil - 0.00338 * A_SAND_M50 + @@ -868,6 +888,8 @@ sptf_whc15 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { #' the water holding capacity given the pedotransferfunction of Wösten et al.2001 (Table 3), for each soil class #' #' @inheritParams sptf_bd0 + + #' #' @import data.table #' @@ -888,9 +910,9 @@ sptf_whc16 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { # Check input arg.length <-max(length(A_SOM_LOI), length(A_CLAY_MI),length(A_SILT_MI)) - checkmate::assert_numeric(A_SOM_LOI, lower = 0, upper = 100,len = arg.length) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length) + check_numeric('A_SOM_LOI', A_SOM_LOI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) checkmate::assert_numeric(mp_fc, any.missing = FALSE) checkmate::assert_numeric(mp_wp, any.missing = FALSE) @@ -903,7 +925,7 @@ sptf_whc16 <- function(A_SOM_LOI,A_CLAY_MI,A_SILT_MI) { A_SAND_M50 = A_SAND_M50, A_LOAM_MI = (A_CLAY_MI + A_SILT_MI), value = NA_real_) - + dt[A_CLAY_MI <= 8, CF1 := 0] dt[A_CLAY_MI > 8, CF1 := 1] @@ -1006,13 +1028,16 @@ calc_soil_porosity <- function(D_BDS, method = "average") { # check inputs arg.length <- max(length(D_BDS)) - checkmate::assert_subset(method, choices = c('Heinen', 'average')) - checkmate::assert_numeric(A_CLAY_MI, lower = 0, upper = 100, len = arg.length,null.ok = TRUE) - checkmate::assert_numeric(A_SILT_MI, lower = 0, upper = 100, len = arg.length,null.ok = TRUE) - checkmate::assert_numeric(A_SAND_MI, lower = 0, upper = 100, len = arg.length,null.ok = TRUE) - checkmate::assert_numeric(A_SOM_LOI, lower = 0, upper = 100, len = arg.length,null.ok = TRUE) - checkmate::assert_numeric(D_BDS, lower = 0, upper = 2000, len = arg.length) - + check_numeric('D_BDS', D_BDS, FALSE, arg.length) + checkmate::assert_subset(method, choices = c('Heinen', 'average'), empty.ok = FALSE) + checkmate::assert_character(method, len = 1) + if(method == 'Heinen'){ + check_numeric('A_SAND_MI', A_SAND_MI, FALSE, arg.length) + check_numeric('A_CLAY_MI', A_CLAY_MI, FALSE, arg.length) + check_numeric('A_SILT_MI', A_SILT_MI, FALSE, arg.length) + check_numeric('A_SOM_LOI', A_SOM_LOI, FALSE, arg.length) + } + if (method == "Heinen") { # Calulate soil density (g/cm3), according to Heinen 2006 # Heinen, M., (2006) Application of a widely used denitrification model to Dutch datasets. Geoderma 133, 464e473. diff --git a/man/sptf_whc3.Rd b/man/sptf_whc3.Rd index a9a09d3..d048ca6 100644 --- a/man/sptf_whc3.Rd +++ b/man/sptf_whc3.Rd @@ -4,12 +4,14 @@ \alias{sptf_whc3} \title{Calculate the water holding capacity given the pedotransferfunction of Saxton et al.1986} \usage{ -sptf_whc3(A_SAND_MI, A_CLAY_MI) +sptf_whc3(A_SAND_MI, A_CLAY_MI, mp_fc = 33) } \arguments{ \item{A_SAND_MI}{(numeric) Sand content (\%)} \item{A_CLAY_MI}{(numeric) The clay content of the mineral soil fraction (\%).} + +\item{mp_fc}{(numeric) Water potential at field capacity (kPa).} } \description{ Calculate the water holding capacity given the pedotransferfunction of Saxton et al.1986 diff --git a/man/sptf_whc4.Rd b/man/sptf_whc4.Rd index 4dfc908..d7b30a6 100644 --- a/man/sptf_whc4.Rd +++ b/man/sptf_whc4.Rd @@ -17,7 +17,7 @@ sptf_whc4(A_C_OF, A_CLAY_MI, A_SAND_MI) Calculate the waterholding capacity given the pedotransferfunction of Oosterveld and Chang (1980) } \details{ -For this function A_DEPTH should be between 0.08 and 0.18 +For this function, A_DEPTH should be between 0.08 and 1.8 m } \references{ Oosterveld and Chang (1980) Empirical relations between laboratory determinations of soil texture and moisture retention diff --git a/renv/.gitignore b/renv/.gitignore deleted file mode 100644 index 22a0d01..0000000 --- a/renv/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -sandbox/ -library/ -local/ -cellar/ -lock/ -python/ -staging/ diff --git a/renv/activate.R b/renv/activate.R deleted file mode 100644 index e17d588..0000000 --- a/renv/activate.R +++ /dev/null @@ -1,1020 +0,0 @@ - -local({ - - # the requested version of renv - version <- "0.17.2" - - # the project directory - project <- getwd() - - # figure out whether the autoloader is enabled - enabled <- local({ - - # first, check config option - override <- getOption("renv.config.autoloader.enabled") - if (!is.null(override)) - return(override) - - # next, check environment variables - # TODO: prefer using the configuration one in the future - envvars <- c( - "RENV_CONFIG_AUTOLOADER_ENABLED", - "RENV_AUTOLOADER_ENABLED", - "RENV_ACTIVATE_PROJECT" - ) - - for (envvar in envvars) { - envval <- Sys.getenv(envvar, unset = NA) - if (!is.na(envval)) - return(tolower(envval) %in% c("true", "t", "1")) - } - - # enable by default - TRUE - - }) - - if (!enabled) - return(FALSE) - - # avoid recursion - if (identical(getOption("renv.autoloader.running"), TRUE)) { - warning("ignoring recursive attempt to run renv autoloader") - return(invisible(TRUE)) - } - - # signal that we're loading renv during R startup - options(renv.autoloader.running = TRUE) - on.exit(options(renv.autoloader.running = NULL), add = TRUE) - - # signal that we've consented to use renv - options(renv.consent = TRUE) - - # load the 'utils' package eagerly -- this ensures that renv shims, which - # mask 'utils' packages, will come first on the search path - library(utils, lib.loc = .Library) - - # unload renv if it's already been loaded - if ("renv" %in% loadedNamespaces()) - unloadNamespace("renv") - - # load bootstrap tools - `%||%` <- function(x, y) { - if (is.environment(x) || length(x)) x else y - } - - bootstrap <- function(version, library) { - - # attempt to download renv - tarball <- tryCatch(renv_bootstrap_download(version), error = identity) - if (inherits(tarball, "error")) - stop("failed to download renv ", version) - - # now attempt to install - status <- tryCatch(renv_bootstrap_install(version, tarball, library), error = identity) - if (inherits(status, "error")) - stop("failed to install renv ", version) - - } - - renv_bootstrap_tests_running <- function() { - getOption("renv.tests.running", default = FALSE) - } - - renv_bootstrap_repos <- function() { - - # check for repos override - repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) - if (!is.na(repos)) - return(repos) - - # check for lockfile repositories - repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) - if (!inherits(repos, "error") && length(repos)) - return(repos) - - # if we're testing, re-use the test repositories - if (renv_bootstrap_tests_running()) { - repos <- getOption("renv.tests.repos") - if (!is.null(repos)) - return(repos) - } - - # retrieve current repos - repos <- getOption("repos") - - # ensure @CRAN@ entries are resolved - repos[repos == "@CRAN@"] <- getOption( - "renv.repos.cran", - "https://cloud.r-project.org" - ) - - # add in renv.bootstrap.repos if set - default <- c(FALLBACK = "https://cloud.r-project.org") - extra <- getOption("renv.bootstrap.repos", default = default) - repos <- c(repos, extra) - - # remove duplicates that might've snuck in - dupes <- duplicated(repos) | duplicated(names(repos)) - repos[!dupes] - - } - - renv_bootstrap_repos_lockfile <- function() { - - lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") - if (!file.exists(lockpath)) - return(NULL) - - lockfile <- tryCatch(renv_json_read(lockpath), error = identity) - if (inherits(lockfile, "error")) { - warning(lockfile) - return(NULL) - } - - repos <- lockfile$R$Repositories - if (length(repos) == 0) - return(NULL) - - keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) - vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) - names(vals) <- keys - - return(vals) - - } - - renv_bootstrap_download <- function(version) { - - # if the renv version number has 4 components, assume it must - # be retrieved via github - nv <- numeric_version(version) - components <- unclass(nv)[[1]] - - # if this appears to be a development version of 'renv', we'll - # try to restore from github - dev <- length(components) == 4L - - # begin collecting different methods for finding renv - methods <- c( - renv_bootstrap_download_tarball, - if (dev) - renv_bootstrap_download_github - else c( - renv_bootstrap_download_cran_latest, - renv_bootstrap_download_cran_archive - ) - ) - - for (method in methods) { - path <- tryCatch(method(version), error = identity) - if (is.character(path) && file.exists(path)) - return(path) - } - - stop("failed to download renv ", version) - - } - - renv_bootstrap_download_impl <- function(url, destfile) { - - mode <- "wb" - - # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 - fixup <- - Sys.info()[["sysname"]] == "Windows" && - substring(url, 1L, 5L) == "file:" - - if (fixup) - mode <- "w+b" - - args <- list( - url = url, - destfile = destfile, - mode = mode, - quiet = TRUE - ) - - if ("headers" %in% names(formals(utils::download.file))) - args$headers <- renv_bootstrap_download_custom_headers(url) - - do.call(utils::download.file, args) - - } - - renv_bootstrap_download_custom_headers <- function(url) { - - headers <- getOption("renv.download.headers") - if (is.null(headers)) - return(character()) - - if (!is.function(headers)) - stopf("'renv.download.headers' is not a function") - - headers <- headers(url) - if (length(headers) == 0L) - return(character()) - - if (is.list(headers)) - headers <- unlist(headers, recursive = FALSE, use.names = TRUE) - - ok <- - is.character(headers) && - is.character(names(headers)) && - all(nzchar(names(headers))) - - if (!ok) - stop("invocation of 'renv.download.headers' did not return a named character vector") - - headers - - } - - renv_bootstrap_download_cran_latest <- function(version) { - - spec <- renv_bootstrap_download_cran_latest_find(version) - type <- spec$type - repos <- spec$repos - - message("* Downloading renv ", version, " ... ", appendLF = FALSE) - - baseurl <- utils::contrib.url(repos = repos, type = type) - ext <- if (identical(type, "source")) - ".tar.gz" - else if (Sys.info()[["sysname"]] == "Windows") - ".zip" - else - ".tgz" - name <- sprintf("renv_%s%s", version, ext) - url <- paste(baseurl, name, sep = "/") - - destfile <- file.path(tempdir(), name) - status <- tryCatch( - renv_bootstrap_download_impl(url, destfile), - condition = identity - ) - - if (inherits(status, "condition")) { - message("FAILED") - return(FALSE) - } - - # report success and return - message("OK (downloaded ", type, ")") - destfile - - } - - renv_bootstrap_download_cran_latest_find <- function(version) { - - # check whether binaries are supported on this system - binary <- - getOption("renv.bootstrap.binary", default = TRUE) && - !identical(.Platform$pkgType, "source") && - !identical(getOption("pkgType"), "source") && - Sys.info()[["sysname"]] %in% c("Darwin", "Windows") - - types <- c(if (binary) "binary", "source") - - # iterate over types + repositories - for (type in types) { - for (repos in renv_bootstrap_repos()) { - - # retrieve package database - db <- tryCatch( - as.data.frame( - utils::available.packages(type = type, repos = repos), - stringsAsFactors = FALSE - ), - error = identity - ) - - if (inherits(db, "error")) - next - - # check for compatible entry - entry <- db[db$Package %in% "renv" & db$Version %in% version, ] - if (nrow(entry) == 0) - next - - # found it; return spec to caller - spec <- list(entry = entry, type = type, repos = repos) - return(spec) - - } - } - - # if we got here, we failed to find renv - fmt <- "renv %s is not available from your declared package repositories" - stop(sprintf(fmt, version)) - - } - - renv_bootstrap_download_cran_archive <- function(version) { - - name <- sprintf("renv_%s.tar.gz", version) - repos <- renv_bootstrap_repos() - urls <- file.path(repos, "src/contrib/Archive/renv", name) - destfile <- file.path(tempdir(), name) - - message("* Downloading renv ", version, " ... ", appendLF = FALSE) - - for (url in urls) { - - status <- tryCatch( - renv_bootstrap_download_impl(url, destfile), - condition = identity - ) - - if (identical(status, 0L)) { - message("OK") - return(destfile) - } - - } - - message("FAILED") - return(FALSE) - - } - - renv_bootstrap_download_tarball <- function(version) { - - # if the user has provided the path to a tarball via - # an environment variable, then use it - tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) - if (is.na(tarball)) - return() - - # allow directories - if (dir.exists(tarball)) { - name <- sprintf("renv_%s.tar.gz", version) - tarball <- file.path(tarball, name) - } - - # bail if it doesn't exist - if (!file.exists(tarball)) { - - # let the user know we weren't able to honour their request - fmt <- "* RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." - msg <- sprintf(fmt, tarball) - warning(msg) - - # bail - return() - - } - - fmt <- "* Bootstrapping with tarball at path '%s'." - msg <- sprintf(fmt, tarball) - message(msg) - - tarball - - } - - renv_bootstrap_download_github <- function(version) { - - enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") - if (!identical(enabled, "TRUE")) - return(FALSE) - - # prepare download options - pat <- Sys.getenv("GITHUB_PAT") - if (nzchar(Sys.which("curl")) && nzchar(pat)) { - fmt <- "--location --fail --header \"Authorization: token %s\"" - extra <- sprintf(fmt, pat) - saved <- options("download.file.method", "download.file.extra") - options(download.file.method = "curl", download.file.extra = extra) - on.exit(do.call(base::options, saved), add = TRUE) - } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { - fmt <- "--header=\"Authorization: token %s\"" - extra <- sprintf(fmt, pat) - saved <- options("download.file.method", "download.file.extra") - options(download.file.method = "wget", download.file.extra = extra) - on.exit(do.call(base::options, saved), add = TRUE) - } - - message("* Downloading renv ", version, " from GitHub ... ", appendLF = FALSE) - - url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) - name <- sprintf("renv_%s.tar.gz", version) - destfile <- file.path(tempdir(), name) - - status <- tryCatch( - renv_bootstrap_download_impl(url, destfile), - condition = identity - ) - - if (!identical(status, 0L)) { - message("FAILED") - return(FALSE) - } - - message("OK") - return(destfile) - - } - - renv_bootstrap_install <- function(version, tarball, library) { - - # attempt to install it into project library - message("* Installing renv ", version, " ... ", appendLF = FALSE) - dir.create(library, showWarnings = FALSE, recursive = TRUE) - - # invoke using system2 so we can capture and report output - bin <- R.home("bin") - exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" - r <- file.path(bin, exe) - - args <- c( - "--vanilla", "CMD", "INSTALL", "--no-multiarch", - "-l", shQuote(path.expand(library)), - shQuote(path.expand(tarball)) - ) - - output <- system2(r, args, stdout = TRUE, stderr = TRUE) - message("Done!") - - # check for successful install - status <- attr(output, "status") - if (is.numeric(status) && !identical(status, 0L)) { - header <- "Error installing renv:" - lines <- paste(rep.int("=", nchar(header)), collapse = "") - text <- c(header, lines, output) - writeLines(text, con = stderr()) - } - - status - - } - - renv_bootstrap_platform_prefix <- function() { - - # construct version prefix - version <- paste(R.version$major, R.version$minor, sep = ".") - prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") - - # include SVN revision for development versions of R - # (to avoid sharing platform-specific artefacts with released versions of R) - devel <- - identical(R.version[["status"]], "Under development (unstable)") || - identical(R.version[["nickname"]], "Unsuffered Consequences") - - if (devel) - prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") - - # build list of path components - components <- c(prefix, R.version$platform) - - # include prefix if provided by user - prefix <- renv_bootstrap_platform_prefix_impl() - if (!is.na(prefix) && nzchar(prefix)) - components <- c(prefix, components) - - # build prefix - paste(components, collapse = "/") - - } - - renv_bootstrap_platform_prefix_impl <- function() { - - # if an explicit prefix has been supplied, use it - prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) - if (!is.na(prefix)) - return(prefix) - - # if the user has requested an automatic prefix, generate it - auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) - if (auto %in% c("TRUE", "True", "true", "1")) - return(renv_bootstrap_platform_prefix_auto()) - - # empty string on failure - "" - - } - - renv_bootstrap_platform_prefix_auto <- function() { - - prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) - if (inherits(prefix, "error") || prefix %in% "unknown") { - - msg <- paste( - "failed to infer current operating system", - "please file a bug report at https://github.com/rstudio/renv/issues", - sep = "; " - ) - - warning(msg) - - } - - prefix - - } - - renv_bootstrap_platform_os <- function() { - - sysinfo <- Sys.info() - sysname <- sysinfo[["sysname"]] - - # handle Windows + macOS up front - if (sysname == "Windows") - return("windows") - else if (sysname == "Darwin") - return("macos") - - # check for os-release files - for (file in c("/etc/os-release", "/usr/lib/os-release")) - if (file.exists(file)) - return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) - - # check for redhat-release files - if (file.exists("/etc/redhat-release")) - return(renv_bootstrap_platform_os_via_redhat_release()) - - "unknown" - - } - - renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { - - # read /etc/os-release - release <- utils::read.table( - file = file, - sep = "=", - quote = c("\"", "'"), - col.names = c("Key", "Value"), - comment.char = "#", - stringsAsFactors = FALSE - ) - - vars <- as.list(release$Value) - names(vars) <- release$Key - - # get os name - os <- tolower(sysinfo[["sysname"]]) - - # read id - id <- "unknown" - for (field in c("ID", "ID_LIKE")) { - if (field %in% names(vars) && nzchar(vars[[field]])) { - id <- vars[[field]] - break - } - } - - # read version - version <- "unknown" - for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { - if (field %in% names(vars) && nzchar(vars[[field]])) { - version <- vars[[field]] - break - } - } - - # join together - paste(c(os, id, version), collapse = "-") - - } - - renv_bootstrap_platform_os_via_redhat_release <- function() { - - # read /etc/redhat-release - contents <- readLines("/etc/redhat-release", warn = FALSE) - - # infer id - id <- if (grepl("centos", contents, ignore.case = TRUE)) - "centos" - else if (grepl("redhat", contents, ignore.case = TRUE)) - "redhat" - else - "unknown" - - # try to find a version component (very hacky) - version <- "unknown" - - parts <- strsplit(contents, "[[:space:]]")[[1L]] - for (part in parts) { - - nv <- tryCatch(numeric_version(part), error = identity) - if (inherits(nv, "error")) - next - - version <- nv[1, 1] - break - - } - - paste(c("linux", id, version), collapse = "-") - - } - - renv_bootstrap_library_root_name <- function(project) { - - # use project name as-is if requested - asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") - if (asis) - return(basename(project)) - - # otherwise, disambiguate based on project's path - id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) - paste(basename(project), id, sep = "-") - - } - - renv_bootstrap_library_root <- function(project) { - - prefix <- renv_bootstrap_profile_prefix() - - path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) - if (!is.na(path)) - return(paste(c(path, prefix), collapse = "/")) - - path <- renv_bootstrap_library_root_impl(project) - if (!is.null(path)) { - name <- renv_bootstrap_library_root_name(project) - return(paste(c(path, prefix, name), collapse = "/")) - } - - renv_bootstrap_paths_renv("library", project = project) - - } - - renv_bootstrap_library_root_impl <- function(project) { - - root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) - if (!is.na(root)) - return(root) - - type <- renv_bootstrap_project_type(project) - if (identical(type, "package")) { - userdir <- renv_bootstrap_user_dir() - return(file.path(userdir, "library")) - } - - } - - renv_bootstrap_validate_version <- function(version) { - - loadedversion <- utils::packageDescription("renv", fields = "Version") - if (version == loadedversion) - return(TRUE) - - # assume four-component versions are from GitHub; - # three-component versions are from CRAN - components <- strsplit(loadedversion, "[.-]")[[1]] - remote <- if (length(components) == 4L) - paste("rstudio/renv", loadedversion, sep = "@") - else - paste("renv", loadedversion, sep = "@") - - fmt <- paste( - "renv %1$s was loaded from project library, but this project is configured to use renv %2$s.", - "Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.", - "Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library.", - sep = "\n" - ) - - msg <- sprintf(fmt, loadedversion, version, remote) - warning(msg, call. = FALSE) - - FALSE - - } - - renv_bootstrap_hash_text <- function(text) { - - hashfile <- tempfile("renv-hash-") - on.exit(unlink(hashfile), add = TRUE) - - writeLines(text, con = hashfile) - tools::md5sum(hashfile) - - } - - renv_bootstrap_load <- function(project, libpath, version) { - - # try to load renv from the project library - if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) - return(FALSE) - - # warn if the version of renv loaded does not match - renv_bootstrap_validate_version(version) - - # execute renv load hooks, if any - hooks <- getHook("renv::autoload") - for (hook in hooks) - if (is.function(hook)) - tryCatch(hook(), error = warning) - - # load the project - renv::load(project) - - TRUE - - } - - renv_bootstrap_profile_load <- function(project) { - - # if RENV_PROFILE is already set, just use that - profile <- Sys.getenv("RENV_PROFILE", unset = NA) - if (!is.na(profile) && nzchar(profile)) - return(profile) - - # check for a profile file (nothing to do if it doesn't exist) - path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) - if (!file.exists(path)) - return(NULL) - - # read the profile, and set it if it exists - contents <- readLines(path, warn = FALSE) - if (length(contents) == 0L) - return(NULL) - - # set RENV_PROFILE - profile <- contents[[1L]] - if (!profile %in% c("", "default")) - Sys.setenv(RENV_PROFILE = profile) - - profile - - } - - renv_bootstrap_profile_prefix <- function() { - profile <- renv_bootstrap_profile_get() - if (!is.null(profile)) - return(file.path("profiles", profile, "renv")) - } - - renv_bootstrap_profile_get <- function() { - profile <- Sys.getenv("RENV_PROFILE", unset = "") - renv_bootstrap_profile_normalize(profile) - } - - renv_bootstrap_profile_set <- function(profile) { - profile <- renv_bootstrap_profile_normalize(profile) - if (is.null(profile)) - Sys.unsetenv("RENV_PROFILE") - else - Sys.setenv(RENV_PROFILE = profile) - } - - renv_bootstrap_profile_normalize <- function(profile) { - - if (is.null(profile) || profile %in% c("", "default")) - return(NULL) - - profile - - } - - renv_bootstrap_path_absolute <- function(path) { - - substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( - substr(path, 1L, 1L) %in% c(letters, LETTERS) && - substr(path, 2L, 3L) %in% c(":/", ":\\") - ) - - } - - renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { - renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") - root <- if (renv_bootstrap_path_absolute(renv)) NULL else project - prefix <- if (profile) renv_bootstrap_profile_prefix() - components <- c(root, renv, prefix, ...) - paste(components, collapse = "/") - } - - renv_bootstrap_project_type <- function(path) { - - descpath <- file.path(path, "DESCRIPTION") - if (!file.exists(descpath)) - return("unknown") - - desc <- tryCatch( - read.dcf(descpath, all = TRUE), - error = identity - ) - - if (inherits(desc, "error")) - return("unknown") - - type <- desc$Type - if (!is.null(type)) - return(tolower(type)) - - package <- desc$Package - if (!is.null(package)) - return("package") - - "unknown" - - } - - renv_bootstrap_user_dir <- function() { - dir <- renv_bootstrap_user_dir_impl() - path.expand(chartr("\\", "/", dir)) - } - - renv_bootstrap_user_dir_impl <- function() { - - # use local override if set - override <- getOption("renv.userdir.override") - if (!is.null(override)) - return(override) - - # use R_user_dir if available - tools <- asNamespace("tools") - if (is.function(tools$R_user_dir)) - return(tools$R_user_dir("renv", "cache")) - - # try using our own backfill for older versions of R - envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") - for (envvar in envvars) { - root <- Sys.getenv(envvar, unset = NA) - if (!is.na(root)) - return(file.path(root, "R/renv")) - } - - # use platform-specific default fallbacks - if (Sys.info()[["sysname"]] == "Windows") - file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") - else if (Sys.info()[["sysname"]] == "Darwin") - "~/Library/Caches/org.R-project.R/R/renv" - else - "~/.cache/R/renv" - - } - - - renv_json_read <- function(file = NULL, text = NULL) { - - jlerr <- NULL - - # if jsonlite is loaded, use that instead - if ("jsonlite" %in% loadedNamespaces()) { - - json <- catch(renv_json_read_jsonlite(file, text)) - if (!inherits(json, "error")) - return(json) - - jlerr <- json - - } - - # otherwise, fall back to the default JSON reader - json <- catch(renv_json_read_default(file, text)) - if (!inherits(json, "error")) - return(json) - - # report an error - if (!is.null(jlerr)) - stop(jlerr) - else - stop(json) - - } - - renv_json_read_jsonlite <- function(file = NULL, text = NULL) { - text <- paste(text %||% read(file), collapse = "\n") - jsonlite::fromJSON(txt = text, simplifyVector = FALSE) - } - - renv_json_read_default <- function(file = NULL, text = NULL) { - - # find strings in the JSON - text <- paste(text %||% read(file), collapse = "\n") - pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' - locs <- gregexpr(pattern, text, perl = TRUE)[[1]] - - # if any are found, replace them with placeholders - replaced <- text - strings <- character() - replacements <- character() - - if (!identical(c(locs), -1L)) { - - # get the string values - starts <- locs - ends <- locs + attr(locs, "match.length") - 1L - strings <- substring(text, starts, ends) - - # only keep those requiring escaping - strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) - - # compute replacements - replacements <- sprintf('"\032%i\032"', seq_along(strings)) - - # replace the strings - mapply(function(string, replacement) { - replaced <<- sub(string, replacement, replaced, fixed = TRUE) - }, strings, replacements) - - } - - # transform the JSON into something the R parser understands - transformed <- replaced - transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) - transformed <- gsub("[[{]", "list(", transformed, perl = TRUE) - transformed <- gsub("[]}]", ")", transformed, perl = TRUE) - transformed <- gsub(":", "=", transformed, fixed = TRUE) - text <- paste(transformed, collapse = "\n") - - # parse it - json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] - - # construct map between source strings, replaced strings - map <- as.character(parse(text = strings)) - names(map) <- as.character(parse(text = replacements)) - - # convert to list - map <- as.list(map) - - # remap strings in object - remapped <- renv_json_remap(json, map) - - # evaluate - eval(remapped, envir = baseenv()) - - } - - renv_json_remap <- function(json, map) { - - # fix names - if (!is.null(names(json))) { - lhs <- match(names(json), names(map), nomatch = 0L) - rhs <- match(names(map), names(json), nomatch = 0L) - names(json)[rhs] <- map[lhs] - } - - # fix values - if (is.character(json)) - return(map[[json]] %||% json) - - # handle true, false, null - if (is.name(json)) { - text <- as.character(json) - if (text == "true") - return(TRUE) - else if (text == "false") - return(FALSE) - else if (text == "null") - return(NULL) - } - - # recurse - if (is.recursive(json)) { - for (i in seq_along(json)) { - json[i] <- list(renv_json_remap(json[[i]], map)) - } - } - - json - - } - - # load the renv profile, if any - renv_bootstrap_profile_load(project) - - # construct path to library root - root <- renv_bootstrap_library_root(project) - - # construct library prefix for platform - prefix <- renv_bootstrap_platform_prefix() - - # construct full libpath - libpath <- file.path(root, prefix) - - # attempt to load - if (renv_bootstrap_load(project, libpath, version)) - return(TRUE) - - # load failed; inform user we're about to bootstrap - prefix <- paste("# Bootstrapping renv", version) - postfix <- paste(rep.int("-", 77L - nchar(prefix)), collapse = "") - header <- paste(prefix, postfix) - message(header) - - # perform bootstrap - bootstrap(version, libpath) - - # exit early if we're just testing bootstrap - if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) - return(TRUE) - - # try again to load - if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { - message("* Successfully installed and loaded renv ", version, ".") - return(renv::load()) - } - - # failed to download or load renv; warn the user - msg <- c( - "Failed to find an renv installation: the project will not be loaded.", - "Use `renv::activate()` to re-initialize the project." - ) - - warning(paste(msg, collapse = "\n"), call. = FALSE) - -}) diff --git a/renv/settings.dcf b/renv/settings.dcf deleted file mode 100644 index 169d82f..0000000 --- a/renv/settings.dcf +++ /dev/null @@ -1,10 +0,0 @@ -bioconductor.version: -external.libraries: -ignored.packages: -package.dependency.fields: Imports, Depends, LinkingTo -r.version: -snapshot.type: implicit -use.cache: TRUE -vcs.ignore.cellar: TRUE -vcs.ignore.library: TRUE -vcs.ignore.local: TRUE diff --git a/renv/settings.json b/renv/settings.json deleted file mode 100644 index 3331ef2..0000000 --- a/renv/settings.json +++ /dev/null @@ -1,17 +0,0 @@ -{ - "bioconductor.version": [], - "external.libraries": [], - "ignored.packages": [], - "package.dependency.fields": [ - "Imports", - "Depends", - "LinkingTo" - ], - "r.version": [], - "snapshot.type": "implicit", - "use.cache": true, - "vcs.ignore.cellar": true, - "vcs.ignore.library": true, - "vcs.ignore.local": true, - "vcs.manage.ignores": true -} diff --git a/tests/testthat/test-sptf-whc.R b/tests/testthat/test-sptf-whc.R index 7ff6b73..888ecb9 100644 --- a/tests/testthat/test-sptf-whc.R +++ b/tests/testthat/test-sptf-whc.R @@ -1,6 +1,5 @@ # test bulk density functions require(testthat) -# require(euptf2) test_that("water holding capacity functions returns the correct values", { @@ -77,20 +76,6 @@ test_that("water holding capacity functions returns the correct values", { tolerance = 0.01 ) - # expect_equal( - # sptf_whc7( - # A_SAND_MI = A_SAND_MI, - # A_CLAY_MI = A_CLAY_MI, - # A_SILT_MI = A_SILT_MI, - # D_BDS = D_BDS, - # A_C_OF = A_C_OF, - # A_DEPTH = c(.15, .15), - # mp_wp = c(1500, 1500), - # mp_fc = c(33, 33)), - # expected = c(,), - # tolerance = 0.01 - # ) - expect_equal( sptf_whc8( A_C_OF = A_C_OF,