Assert bln field inputs

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: BLN
 Type: Package
 Title: Calculate the Soil Quality Assessment Score using the Dutch BLN framework
-Version: 0.10.0
+Version: 0.11.0
 Authors@R: c(
     person("Gerard", "Ros", email = "gerard.ros@nmi-agro.nl", role = c("aut","cre"), comment = c(ORCID = '0000-0002-6062-9770')),
     person("Sven", "Verweij", email = "sven.verweij@nmi-agro.nl", role = "aut", comment = c(ORCID = '0000-0002-5573-3952')),
@@ -25,15 +25,16 @@ Imports:
     parallelly,
     deSolve,
     ggplot2,
-    patchwork
+    patchwork,
+    methods
 License: 
     GPL-3
 URL: https://github.com/AgroCares/BLN,
     https://agrocares.github.io/BLN/
 BugReports: https://github.com/AgroCares/BLN/issues
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.3
 Suggests: 
     testthat (>= 2.1.0),
     knitr,

NAMESPACE

@@ -40,7 +40,7 @@ export(bln_p_sealing)
 export(bln_p_waterstress)
 export(bln_p_wetnessstress)
 export(bln_p_whc)
-export(bln_p_windererosion)
+export(bln_p_winderosion)
 export(bln_p_workability)
 export(bln_rothc)
 export(bln_rothc_event)
@@ -60,6 +60,8 @@ export(bln_wat_nrunoff)
 export(bln_wat_pesticide)
 export(cf_ind_importance)
 export(checkvar)
+export(funArgs)
+export(funArgsV)
 export(ind_workability)
 export(pF_curve)
 export(pFpara_class)
@@ -81,6 +83,7 @@ import(ggplot2)
 import(parallelly)
 import(patchwork)
 import(progressr)
+importFrom(methods,existsFunction)
 importFrom(stats,pnorm)
 importFrom(utils,setTxtProgressBar)
 importFrom(utils,txtProgressBar)

NEWS.md

@@ -1,3 +1,20 @@
+# BLN 0.11.0 2025-xx-xx
+## Changed
+* Made function argument checking for bln_field more strict.
+* Changed type of columns 'id' and 'B_LSW_ID' of table `bln_farm_hf` from type
+integer to type character in line with function documentation.
+
+## Added
+* New helper function `funArgs`  to retrieve unique argument names from function names
+* New helper function `funArgsV` to retrieve unique argument names from a vector of function names
+* New helper functions `blnAssertLower` and `blnAssertUpper` to aid in function argument assertions
+* more variables to table `bln_parms`
+* Table `bln_variable_grouping` which links BLN functions to indicators and groups
+them by ecosystem service theme and sub-groups
+
+## Fixed
+* Renamed function `bln_p_windererosion` to `bln_p_winderosion`
+
 # BLN 0.10.0 2025-xx-xx
 ## Changed
 * the format of groundwater class values (B_GWL_CLASS) that are accepted by BLN 

R/bln_helpers.R

@@ -401,3 +401,130 @@ bln_format_aer <- function(B_AER_CBS,type='name') {
   # Return B_AER_CBS
   return(B_AER_CBS)
 }
+
+#' Get vector of function arguments
+#'
+#' @param functionName Quoted name of a function
+#' @param whichArgs Select whether you want to return all arguments ('all'),
+#' arguments without defaults ('required') or arguments with defaults ('optional'). Default is 'all'.
+#'
+#' @examples
+#' funArgs('sd')
+#' funArgs('sd', whichArgs = 'required')
+#' funArgs('sd', whichArgs = 'optional')
+#'
+#' @return a character vector of function argument names
+#' @importFrom methods existsFunction
+#' @export
+funArgs <- function(functionName, whichArgs = 'all'){
+  checkmate::assert_character(functionName)
+  checkmate::assert_true(existsFunction(functionName), .var.name = paste0('existsFunction(',functionName, ')'))
+  checkmate::assert_subset(whichArgs,
+                           choices = c('all', 'required', 'optional'))
+
+  arg.list <- formals(functionName)
+  functionArguments <- character(0)
+
+  if (whichArgs == 'all') {
+    functionArguments <- names(arg.list)
+  } else {
+    has_default <- sapply(arg.list, function(arg) !identical(arg, substitute()))
+    if (whichArgs == 'optional') {
+      functionArguments <- names(arg.list)[has_default]
+    } else { # 'required'
+      functionArguments <- names(arg.list)[!has_default]
+    }
+  }
+
+  return(functionArguments)
+}
+
+#' Get a vector of function arguments for multiple functions
+#'
+#' @description This function is a wrapper around funArgs. It takes a vector of
+#' function names and returns a single character vector with unique argument names.
+#'
+#' @param functionNameVector A character vector of function names.
+#' @param whichArgs Select whether you want to return all arguments ('all'),
+#' arguments without defaults ('required') or arguments with defaults ('optional').
+#' Default is 'all'.
+#'
+#' @return A character vector of unique function argument names.
+#'
+#' @examples
+#' funArgsV(c('sd', 'mean'))
+#' funArgsV(c('sd', 'mean'), whichArgs = 'required')
+#'
+#' @export
+funArgsV <- function(functionNameVector, whichArgs = 'all'){
+
+  # check inputs
+  checkmate::assert_character(functionNameVector, any.missing = FALSE, min.len = 1)
+  checkmate::assert_subset(whichArgs, choices = c('all', 'required', 'optional'))
+
+  # get arguments for all functions in the vector
+  args_list <- lapply(functionNameVector,
+                      FUN = funArgs,
+                      whichArgs = whichArgs)
+
+  # unlist and return unique arguments
+  return(unique(unlist(args_list)))
+}
+
+#' Aid to assert upper values
+#'
+#' Checks whether x is numeric and not NA. If so, returns x, else returns Inf
+#'
+#' @param x a value obtained by `bln_parms[code == 'variable_name', value_max]`
+#'
+#' @return x when it is numeric and not NA, else returns Inf
+#'
+#' @examples
+#' \dontrun{
+#' BLN:::blnAssertUpper(2)
+#' BLN:::blnAssertUpper('')
+#' BLN:::blnAssertUpper(NA_real_)
+#'
+#' # example in context
+#' A_SOM_LOI <- 5
+#' arg.length = length(A_SOM_LOI)
+#' checkmate::assert_numeric(A_SOM_LOI,
+#' any.missing = FALSE, len = arg.length,
+#' upper = BLN:::blnAssertUpper(BLN::bln_parms[code == 'A_SOM_LOI', value_max])
+#' )
+#'}
+#' @keywords internal
+blnAssertUpper <- function(x){
+  out <- NULL
+  if(is.numeric(x) & !is.na(x)){out <- x} else{out <- Inf}
+  return(out)
+}
+
+#' Aid to assert lower values
+#'
+#' Checks whether x is numeric and not NA. If so, returns x, else returns -Inf
+#'
+#' @param x a value obtained by `bln_parms[code == 'variable_name', value_min]`
+#'
+#' @return x when it is numeric and not NA, else returns -Inf
+#'
+#' @examples
+#' \dontrun{
+#' BLN:::blnAssertLower(2)
+#' BLN:::blnAssertLower('')
+#' BLN:::blnAssertLower(NA_real_)
+#'
+#' # example in context
+#' A_SOM_LOI <- 5
+#' arg.length = length(A_SOM_LOI)
+#' checkmate::assert_numeric(A_SOM_LOI,
+#' any.missing = FALSE, len = arg.length,
+#' lower = BLN:::blnAssertLower(BLN::bln_parms[code == 'A_SOM_LOI', value_min])
+#' )
+#'}
+#' @keywords internal
+blnAssertLower <- function(x){
+  out <- NULL
+  if(is.numeric(x) & !is.na(x)){out <- x} else{out <- -Inf}
+  return(out)
+}

R/bln_prod_winderosion.R

@@ -12,7 +12,7 @@
 #' The vulnerability of the soil for wind erosion. A numeric value.
 #'
 #' @export
-bln_p_windererosion <- function(B_LU_BRP,A_CLAY_MI,A_SILT_MI) {
+bln_p_winderosion <- function(B_LU_BRP,A_CLAY_MI,A_SILT_MI) {
 
   # add visual bindings
   id = crop_code = crop_cat1 = loam = NULL

R/bln_prod_workability.R

@@ -79,7 +79,7 @@ bln_p_workability <- function(A_CLAY_MI, A_SILT_MI, B_LU_BRP, B_SOILTYPE_AGR,
 #' This function calculates the indicator for the workability of the soil expressed as the period in which the soil can be worked without
 #' inflicting structural damage that cannot be restored by the regular management on the farm.
 #'
-#' @param D_WO (numeric) The value of the relative (workable) season length calculated by \code{\link{calc_workability}}
+#' @param D_WO (numeric) The value of the relative (workable) season length calculated by \code{\link[OBIC]{calc_workability}}
 #' @param B_LU_BRP (numeric) The crop code from the BRP
 #'
 #' @examples

R/bln_tables.R

@@ -208,3 +208,13 @@
 #'   \item{value_max}{Maximum value for a numeric or integer parameter}
 #' }
 "bln_input_description"
+
+#' Grouping of indicators and BLN functions used for aggregation
+#'
+#' \describe{
+#'   \item{bln_function}{Name of a function in BLN to calculate an indicator}
+#'   \item{variable}{Name of a variable for a specific indicator}
+#'   \item{ess_theme}{Highest order grouping of indicators}
+#'   \item{sub_group}{Second order grouping of indicators}
+#' }
+"bln_variable_grouping"

data-raw/variable_grouping/variable_grouping.R

@@ -0,0 +1,7 @@
+# make a table with soil functions and ecosystem services, how they are grouped
+# and with which functions they are calculated
+library(data.table)
+
+bln_variable_grouping <- fread('data-raw/variable_grouping/variable_grouping.csv')
+usethis::use_data(bln_variable_grouping, overwrite = TRUE)
+fwrite(bln_variable_grouping, 'data-raw/variable_grouping/variable_grouping.csv')

data-raw/variable_grouping/variable_grouping.csv

@@ -0,0 +1,37 @@
+bln_function,variable,ess_theme,sub_group
+bln_c_nitrogen,i_c_n,prod,chemistry
+bln_c_posphor,i_c_p,prod,chemistry
+bln_c_potassium,i_c_k,prod,chemistry
+bln_c_magnesium,i_c_mg,prod,chemistry
+bln_c_sulfur,i_c_s,prod,chemistry
+bln_c_ph,i_c_ph,prod,chemistry
+bln_p_crumbleability,i_p_cr,prod,physics
+bln_p_sealing,i_p_se,prod,physics
+bln_p_droughtstress,i_p_ds,prod,physics
+bln_p_wetnessstress,i_p_ws,prod,physics
+bln_p_winderosion,i_p_du,prod,physics
+bln_p_compaction,i_p_co,prod,physics
+bln_p_compaction,i_p_co,prod,physics
+bln_p_whc,i_p_whc,prod,physics
+bln_p_aggstability,i_p_as,prod,physics
+bln_p_workability,i_p_wo,prod,physics
+bln_b_diseaseresistance,i_b_di,prod,biology
+bln_b_pmn,i_b_sf,prod,biology
+bln_wat_groundwater_recharge,i_gw_gwr,water,gw_quantity
+bln_bbwp_bw,i_gw_wb,water,gw_quality
+bln_wat_pesticide,i_gw_pest,water,gw_quality
+bln_wat_nretention_gw,i_gw_nret,water,gw_quality
+bln_bbwp_ngw,i_gw_ngw,water,gw_quality
+bln_wat_nrisk_gw,i_gw_nlea,water,gw_quality
+bln_wat_nretention_gw,i_e_gw_nret,water,gw_quality
+bln_bbwp_nsw,i_sw_nsw,water,sw_quality
+bln_bbwp_psw,i_sw_psw,water,sw_quality
+bln_wat_nretention_sw,i_sw_nret,water,sw_quality
+bln_wat_nrunoff,i_sw_nro,water,sw_quality
+bln_clim_cbalance,i_clim_osb,climate,climate
+bln_clim_rothc,i_clim_rothc,climate,climate
+bln_clim_somers,i_clim_somers,climate,climate
+bln_nut_nitrogen,i_nut_n,nutcycle,macronutrient
+bln_nut_phosphorus,i_nut_p,nutcycle,macronutrient
+bln_nut_potassium,i_nut_k,nutcycle,macronutrient
+bln_nut_nue,i_nut_nue,nutcycle,macronutrient

dev/bln_tables.R

@@ -22,6 +22,9 @@
   bln_parms[, type := 'measurement']
   bln_parms[grepl('_BCS$', code), type := 'visual soil assessment']
   bln_parms[grepl('^B_', code), type := 'field property']
+  bln_parms[grepl('^M_', code), type := 'soil management measure']
+  bln_parms[grepl('^D_', code), type := 'characteristic derived from measurement']
+  bln_parms[grepl('^I_', code), type := 'indicator']
 
   # select columns
   setnames(bln_parms, 'parameter', 'description')

dev/prep_bln_demarke.R

@@ -344,11 +344,14 @@ bln_farm_hf <- copy(dt.out)
 # rm Gt
 bln_farm_hf[, B_GWL_CLASS := gsub('Gt', '', B_GWL_CLASS)]
 
+# set id to character
+bln_farm_hf[, id := as.character(id)]
+bln_farm_hf[, B_LSW_ID := as.character(B_LSW_ID)]
+
 # save measures as bbwp table
 usethis::use_data(bln_farm_hf, overwrite = TRUE)
 
-
-# prepare LSW datafile for calculations BLN
+# prepare LSW datafile for calculations BLN=======
 
 # shape file to extract data for
 s1.sel <- st_read('dev/bln_demarke.gpkg')