Release v0.2.0

.Rbuildignore

@@ -4,6 +4,9 @@
 # reason, there should not be any blank comment lines, because they would
 # exclude any files with `#` in the filename, possibly causing confusing issues.
 
+^Rhistory$
+# History files
+
 ^.*\.Rproj$
 # Designates the directory as an RStudio Project.
 

.github/workflows/R-CMD-check.yaml

@@ -25,7 +25,7 @@ jobs:
           - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,   r: 'release'}
           - {os: ubuntu-latest,   r: 'oldrel-1'}
-          - {os: ubuntu-latest,   r: '4.0.0'}
+          - {os: ubuntu-latest,   r: '3.6.0'}
 
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}

DESCRIPTION

@@ -1,20 +1,27 @@
 Package: BioCroValidation
-Version: 0.1.0
+Version: 0.2.0
 Title: Tools for Validating BioCro Models
 Description: A collection of tools for validating BioCro crop growth models.
 Authors@R: c(
     person("Edward B.", "Lochocki", role = c('cre', 'aut'),
            email = "eloch@illinois.edu",
            comment = c(ORCID = "0000-0002-4912-9783")),
-    person("BioCroField authors", role = "cph")
+    person("BioCroValidation authors", role = "cph")
     )
+Depends:
+    R (>= 3.6.0)
+Imports:
+    BioCro (>= 3.2.0)
+Suggests:
+    dfoptim,
+    DEoptim,
+    lattice,
+    knitr,
+    rmarkdown,
+    testthat (>= 3.0.0)
+VignetteBuilder: knitr
 License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
-Depends:
-    R (>= 4.0.0)
-Suggests:
-    testthat (>= 3.0.0),
-    BioCro (>= 3.0.0)
-URL: https://github.com/BioCro/BioCroField, https://biocro.github.io/BioCroValidation/
+URL: https://github.com/BioCro/BioCroValidation, https://biocro.github.io/BioCroValidation/
 Config/testthat/edition: 3

LICENSE

@@ -1,2 +1,2 @@
 YEAR: 2025
-COPYRIGHT HOLDER: BioCroField authors
+COPYRIGHT HOLDER: BioCroValidation authors

LICENSE.md

@@ -1,6 +1,6 @@
 # MIT License
 
-Copyright (c) 2025 BioCroField authors
+Copyright (c) 2025 BioCroValidation authors
 
 Permission is hereby granted, free of charge, to any person obtaining a copy
 of this software and associated documentation files (the "Software"), to deal

NAMESPACE

@@ -1 +1,4 @@
+export(bounds_table)
+export(objective_function)
+export(update_model)
 export(write_model)

NEWS.md

@@ -33,10 +33,22 @@ In the case of a hotfix, a short section headed by the new release number should
 be directly added to this file to describe the related changes.
 -->
 
+# Changes in BioCroValidation Version 0.2.0 (2025-05-23)
+
+- Added 2002 and 2005 SoyFACE biomass and standard deviation data.
+
+- Added several new functions: `objective_function`, `update_model`, and
+  `bounds_table`.
+
+- Added two new vignettes: a "Getting Started" article (`BioCroValidation.Rmd`)
+  and a user guide illustrating how to perform a model parameterization
+  (`parameterizing_soybean_biocro.Rmd`).
+
 # Changes in BioCroValidation Version 0.1.0
 
 - This is the first version of BioCroValidation. At this point, the package is
   in a state of rapid development, and not all changes will be described here.
+
 - We are reserving version `1.0.0` for a more stable and complete future
   release; until then, major changes should only increase the minor version
   number.

R/bounds_table.R

@@ -0,0 +1,154 @@
+# A helper function for checking the bounds list for mistakes; if an issue is
+# found, this function will throw an error; otherwise it will be silent with no
+# return value.
+check_bounds_list <- function(bounds_list, independent_args) {
+    # Must be a list of named elements
+    if (!is.list(bounds_list) | is.null(names(bounds_list))) {
+        stop('`bounds_list` must be a list of named elements')
+    }
+
+    # Must contain all elements in independent_args
+    missing_element <- sapply(names(independent_args), function(x) {
+        !x %in% names(bounds_list)
+    })
+
+    if (any(missing_element)) {
+        msg <- paste0(
+            'The following elements were included in ',
+            '`independent_args` but not `bounds_list`: ',
+            paste(names(independent_args)[missing_element], collapse = ', ')
+        )
+        stop(msg)
+    }
+
+    # Each element must have length 2
+    length_two <- sapply(bounds_list, function(x) {
+        xlen <- length(x)
+
+        if (is.finite(xlen)) {
+            length(x) == 2
+        } else {
+            FALSE
+        }
+    })
+
+    if (any(!length_two)) {
+        msg <- paste0(
+            'The following elements of `bounds_list` do not have a length of 2: ',
+            paste(names(bounds_list)[!length_two], collapse = ', ')
+        )
+        stop(msg)
+    }
+
+    # Each element must be numeric
+    not_numeric <- sapply(bounds_list, function(x) {!is.numeric(x)})
+
+    if (any(not_numeric)) {
+        msg <- paste0(
+            'The following elements of `bounds_list` are not numeric: ',
+            paste(names(bounds_list)[not_numeric], collapse = ', ')
+        )
+        stop(msg)
+    }
+
+    return(invisible(NULL))
+}
+
+# A helper function for checking the initial guess for mistakes; if an issue is
+# found, this function will throw an error or a warning; otherwise it will be
+# silent with no return value.
+check_initial_ind_arg_values <- function(
+    independent_args,
+    lbounds,
+    ubounds,
+    initial_ind_arg_values
+)
+{
+    # Check the length
+    if (length(initial_ind_arg_values) != length(independent_args)) {
+        stop('`initial_ind_arg_values` must have the same length as `independent_args`')
+    }
+
+    # Check to make sure the initial values are not outside the bounds
+    outside_bounds <- sapply(seq_along(initial_ind_arg_values), function(i) {
+        initial_ind_arg_values[i] < lbounds[i] | initial_ind_arg_values[i] > ubounds[i]
+    })
+
+    if (any(outside_bounds)) {
+        msg <- paste0(
+            'The initial values for the following arguments lie outside the bounds: ',
+            paste(names(independent_args)[outside_bounds], collapse = ', ')
+        )
+        stop(msg)
+    }
+
+    # Check to see if any initial values are on the bounds
+    eps <- sqrt(.Machine$double.eps)
+
+    on_bounds <- sapply(seq_along(initial_ind_arg_values), function(i) {
+        abs(initial_ind_arg_values[i] - lbounds[i]) < eps |
+            abs(initial_ind_arg_values[i] - ubounds[i]) < eps
+    })
+
+    if (any(on_bounds)) {
+        msg <- paste0(
+            'The initial values for the following arguments lie on the ',
+            'bounds, which can be problematic for some optimizers: ',
+            paste(names(independent_args)[on_bounds], collapse = ', ')
+        )
+        warning(msg)
+    }
+
+    return(invisible(NULL))
+}
+
+bounds_table <- function(
+    independent_args,
+    bounds_list,
+    initial_ind_arg_values = NULL
+)
+{
+    # Check the bounds_list
+    check_bounds_list(bounds_list, independent_args)
+
+    # Get an ordering for the elements of `bounds_list` so they match the order
+    # of elements in `independent_args`; note that this will also exclude any
+    # elements of `bounds_list` that are not included in `independent_args`.
+    ordering <- match(
+        names(independent_args),
+        names(bounds_list)
+    )
+
+    bounds_list <- bounds_list[ordering]
+
+    # Get the lower and upper bounds
+    lbounds <- sapply(bounds_list, min)
+    ubounds <- sapply(bounds_list, max)
+
+    # Form the bounds table
+    bounds_table <- data.frame(
+        arg_name = names(independent_args),
+        lower = lbounds,
+        upper = ubounds,
+        stringsAsFactors = FALSE
+    )
+
+    # Include initial values in the table if they were provided
+    if (!is.null(initial_ind_arg_values)) {
+        # Check the values
+        check_initial_ind_arg_values(
+            independent_args,
+            lbounds,
+            ubounds,
+            initial_ind_arg_values
+        )
+
+        # Include the values
+        bounds_table$initial_value <- initial_ind_arg_values
+    }
+
+    # Remove row names and return the table
+    rownames(bounds_table) <- NULL
+
+    bounds_table
+}

R/objective_function.R

@@ -0,0 +1,134 @@
+## Here we use several functions that are defined in
+## `objective_function_input_checks.R` and `objective_function_helpers.R`
+
+objective_function <- function(
+    base_model_definition,
+    data_driver_pairs,
+    independent_args,
+    quantity_weights,
+    data_definitions = list(),
+    normalization_method = 'mean_max',
+    normalization_param = NULL,
+    stdev_weight_method = 'equal',
+    stdev_weight_param = NULL,
+    regularization_method = 'none',
+    dependent_arg_function = NULL,
+    post_process_function = NULL,
+    extra_penalty_function = NULL,
+    verbose_startup = TRUE
+)
+{
+    # Check the data-driver pairs
+    check_data_driver_pairs(base_model_definition, data_driver_pairs)
+
+    # Check the arguments to be varied
+    check_args_to_vary(
+        independent_args,
+        dependent_arg_function,
+        data_driver_pairs,
+        verbose_startup
+    )
+
+    # Get the model runners
+    model_runners <- lapply(data_driver_pairs, function(ddp) {
+        get_model_runner(
+            base_model_definition,
+            independent_args,
+            dependent_arg_function,
+            post_process_function,
+            ddp
+        )
+    })
+
+    # Get the full data definition list
+    full_data_definitions <-
+        get_data_definition_list(data_driver_pairs, data_definitions)
+
+    # Print the full data definition list, if desired
+    if (verbose_startup) {
+        cat('\nThe full data definitions:\n\n')
+        utils::str(full_data_definitions)
+    }
+
+    # Check the model runners
+    check_runners(model_runners)
+
+    # Get initial model runner results
+    initial_runner_res <-
+        get_initial_runner_res(model_runners, independent_args)
+
+    # Check the initial model runner results
+    check_runner_results(
+        initial_runner_res,
+        full_data_definitions,
+        data_driver_pairs
+    )
+
+    # Get the long-form data
+    long_form_data <-
+        get_long_form_data(data_driver_pairs, full_data_definitions)
+
+    # Find indices corresponding to the measured time points
+    long_form_data <- add_time_indices(initial_runner_res, long_form_data)
+
+    # Add normalization factors
+    long_form_data <- add_norm(
+        long_form_data,
+        normalization_method,
+        normalization_param,
+        length(data_driver_pairs)
+    )
+
+    # Add variance-based weights
+    long_form_data <- add_w_var(
+        long_form_data,
+        stdev_weight_method,
+        stdev_weight_param
+    )
+
+    # Print the long form data, if desired. Do this before checking the data,
+    # so the printout will be available for troubleshooting
+    if (verbose_startup) {
+        cat('\nThe user-supplied data in long form:\n\n')
+        print(long_form_data)
+    }
+
+    # Check the processed long-form data
+    check_long_form_data(long_form_data)
+
+    # Process the quantity weights
+    full_quantity_weights <-
+        process_quantity_weights(quantity_weights, long_form_data)
+
+    # Print the quantity weights, if desired
+    if (verbose_startup) {
+        cat('The user-supplied quantity weights:\n\n')
+        utils::str(full_quantity_weights)
+    }
+
+    # Get the data-driver pair weights
+    ddp_weights <- get_ddp_weights(data_driver_pairs)
+
+    # Print the data-driver pair weights, if desired
+    if (verbose_startup) {
+        cat('\nThe user-supplied data-driver pair weights:\n\n')
+        utils::str(ddp_weights)
+    }
+
+    # Create the objective function
+    obj_fun <- get_obj_fun(
+        model_runners,
+        long_form_data,
+        full_quantity_weights,
+        ddp_weights,
+        normalization_method,
+        extra_penalty_function,
+        regularization_method
+    )
+
+    # Check the objective function
+    check_obj_fun(obj_fun, independent_args, verbose_startup)
+
+    # Return it
+    obj_fun
+}