diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 3e43a4454..57af9ebf0 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -20,7 +20,7 @@ "updatePackages": true }, "ghcr.io/rocker-org/devcontainer-features/r-packages:1": { - "packages": "covr,dplyr,devtools,ggplot2,graphics,jsonlite,github::noaa-afsc/SparseNUTS,methods,Rcpp,RcppEigen,scales,snowfall,TMB,tibble,tidyr,usethis", + "packages": "covr,dplyr,devtools,furrr,future,ggplot2,graphics,jsonlite,github::noaa-afsc/SparseNUTS,methods,Rcpp,RcppEigen,scales,snowfall,TMB,tibble,tidyr,usethis,yardstick", "installSystemRequirements": true } }, diff --git a/.github/workflows/call-update-data-r.yml b/.github/workflows/call-update-data-r.yml new file mode 100644 index 000000000..98c8681f0 --- /dev/null +++ b/.github/workflows/call-update-data-r.yml @@ -0,0 +1,22 @@ +# Update data files in /data whenever changes are made to files in /data-raw. +# This workflow automatically commits changes directly to the working branch. +name: call-update-data-r + +on: + push: + paths: + - 'R/**' + - 'inst/**' + - 'data/**' + - 'data-raw/**' + - 'src/**' + workflow_dispatch: + +jobs: + call-workflow: + if: github.repository == 'NOAA-FIMS/FIMS' + uses: NOAA-FIMS/ecosystemom/.github/workflows/update-data-r.yml@main + secrets: + PAT: ${{ secrets.PAT }} + with: + commit-directly: true \ No newline at end of file diff --git a/.github/workflows/run-slow-tests.yml b/.github/workflows/run-slow-tests.yml index 78c36f93a..3bb9b6117 100644 --- a/.github/workflows/run-slow-tests.yml +++ b/.github/workflows/run-slow-tests.yml @@ -40,7 +40,16 @@ jobs: fail-fast: false matrix: os: [ubuntu-latest, windows-latest, macos-latest] - name: ${{ matrix.os }} + # Adds the split test categories to the matrix + test_type: + - slow + - integration-caa + - integration-fims-bayesian + - integration-fims-estimation-random-effects + - integration-fleet + - integration-proportion + + name: ${{ matrix.os }} (${{ matrix.test_type }}) runs-on: ${{ matrix.os }} env: @@ -85,6 +94,8 @@ jobs: needs: check - name: Run Slow Tests Only + env: + TEST_FILTER: ${{ matrix.test_type }} shell: Rscript {0} run: | # Windows-specific fix for the "files too big" error @@ -92,6 +103,7 @@ jobs: withr::local_options(pkg.build_extra_flags = FALSE) } - # The filter looks for files with 'slow' in the name - devtools::test(filter = "slow") + filter_pattern <- Sys.getenv("TEST_FILTER") + message(paste("Running test suite matching filter:", filter_pattern)) + devtools::test(filter = filter_pattern) diff --git a/.gitignore b/.gitignore index 0b7eeee0f..6d6cd1688 100644 --- a/.gitignore +++ b/.gitignore @@ -97,8 +97,6 @@ src/tmp.def #Testing files -tests/test_plan/FIMS_Integration_Test_Plan.log -tests/integration/FIMS-deterministic-inputs/ tests/testthat/fixtures/fit*.RDS tests/testthat/fixtures/data*.RDS tests/testthat/fixtures/parameters*.RDS diff --git a/R/data_.R b/R/data_.R deleted file mode 100644 index b5d77a05a..000000000 --- a/R/data_.R +++ /dev/null @@ -1,42 +0,0 @@ -#' FIMS input data frame -#' -#' A data frame containing the information needed to run an age-structured stock -#' assessment model in FIMS. This data was generated using -#' the `ASSAMC` package written for the [model comparison project]( -#' www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison). -#' The source code to make this dataset is in `data-raw/data_big.R` which is on -#' GitHub but will not be in your local installation because it is in the -#' .Rbuildignore file. -#' -#' @format -#' A data frame with `r NROW(data_big)` observations of `r NCOL(data_big)` -#' variables: -#' \describe{ -#' \item{type}{The type of input the row contains. Allowed types include -#' `r glue::glue_collapse(fims_input_types, sep = ", ", last = ", and ")`.} -#' \item{fleet}{A character string providing the name of the information -#' source that the input was collected from, e.g., `"Trawl fishery"` or -#' `"age_zero_survey"`. Entries can be `NA` for information that is not -#' fleet/vessel specific.} -#' \item{age}{An integer age. Entry can be `NA` if information pertains to -#' multiple ages, e.g., total landings rather than landings of age-4 fish. -#' In this dataset, ages start at one, therefore recruitment happens at age -#' one not age zero.} -#' \item{length}{A numeric length. Entry can be `NA` if information doesn't -#' pertain to length.} -#' \item{timing}{The timing, i.e., year the data was collected.} -#' \item{value}{The measurement of interest.} -#' \item{unit}{A character string specifying the units of `value`. Allowed -#' units for each data type are as follows. `mt` is used for `index`, -#' `landings`, and `weight_at_age` data. `number` or `proportion` are each -#' viable units for the composition data, where the former is the preferred -#' unit of measurement.} -#' \item{uncertainty}{A real value providing a measurement of uncertainty -#' for value. For landings and indices of abundance this should be -#' the standard deviation of the logged observations if you are using the -#' lognormal distribution to fit your data. For composition data it will -#' be your input sample size. -#' } -#' } -#' @source \url{www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison} -"data_big" diff --git a/R/data_big.R b/R/data_big.R new file mode 100644 index 000000000..0c22d5206 --- /dev/null +++ b/R/data_big.R @@ -0,0 +1,119 @@ +#' FIMS input data frame +#' +#' A data frame containing the information needed to run an age-structured stock +#' assessment model in FIMS. This data was generated using +#' the `ASSAMC` package written for the [model comparison project]( +#' www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison). +#' The source code to make this dataset is in `data-raw/data_big.R` which is on +#' GitHub but will not be in your local installation because it is in the +#' .Rbuildignore file. +#' +#' @format +#' A data frame with `r NROW(data_big)` observations of `r NCOL(data_big)` +#' variables: +#' \describe{ +#' \item{type}{The type of input the row contains. Allowed types include +#' `r glue::glue_collapse(fims_input_types, sep = ", ", last = ", and ")`.} +#' \item{fleet}{A character string providing the name of the information +#' source that the input was collected from, e.g., `"Trawl fishery"` or +#' `"age_zero_survey"`. Entries can be `NA` for information that is not +#' fleet/vessel specific.} +#' \item{age}{An integer age. Entry can be `NA` if information pertains to +#' multiple ages, e.g., total landings rather than landings of age-4 fish. +#' In this dataset, ages start at one, therefore recruitment happens at age +#' one not age zero.} +#' \item{length}{A numeric length. Entry can be `NA` if information doesn't +#' pertain to length.} +#' \item{timing}{The timing, i.e., year the data was collected.} +#' \item{value}{The measurement of interest.} +#' \item{unit}{A character string specifying the units of `value`. Allowed +#' units for each data type are as follows. `mt` is used for `index`, +#' `landings`, and `weight_at_age` data. `number` or `proportion` are each +#' viable units for the composition data, where the former is the preferred +#' unit of measurement.} +#' \item{uncertainty}{A real value providing a measurement of uncertainty +#' for value. For landings and indices of abundance this should be +#' the standard deviation of the logged observations if you are using the +#' lognormal distribution to fit your data. For composition data it will +#' be your input sample size. +#' } +#' } +#' @source \url{www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison} +"data_big" + +#' FIMS parameters tibble +#' +#' A tibble containing the parameters needed to run an age-structured stock +#' assessment model in FIMS. This data was generated using the `ASSAMC` package +#' written for the [model comparison project](www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison). +#' The source code to make this dataset is in `data-raw/parameters_.R` which is +#' on GitHub but will not be in your local installation because it is in the .Rbuildignore file. +#' +#' @format +#' A tibble with `r NROW(parameters_big)` observations of `r NCOL(parameters_big)` variables: +#' \describe{ +#' \item{\code{model_family}:}{The specified model family (e.g., +#' "catch_at_age").} +#' \item{\code{module_name}:}{The name of the FIMS module (e.g., +#' "Data", "Selectivity", "Recruitment", "Growth", "Maturity"). These +#' entries are always written in PascalCase to match the names used in the +#' C++ code.} +#' \item{\code{fleet}:}{The name of the fleet the module applies to. This +#' will be `NA` for non-fleet-specific modules like "Recruitment".} +#' \item{\code{data}:}{A list-column containing a `tibble` with detailed +#' parameters. Unnesting this column reveals: +#' \describe{ +#' \item{\code{module_type}:}{The specific type of the module (e.g., +#' "Logistic" for a "Selectivity" module). This column will always be +#' written in PascalCase to match the names used in the C++ code.} +#' \item{\code{label}:}{The name of the parameter (e.g., +#' "inflection_point").} +#' \item{\code{age}:}{The age the parameter applies to.} +#' \item{\code{length}:}{The length bin the parameter applies to.} +#' \item{\code{time}:}{The time step (i.e., year) the parameter applies +#' to.} +#' \item{\code{value}:}{The initial value of the parameter.} +#' \item{\code{estimation_type}:}{The type of estimation (e.g., +#' "constant", "fixed_effects", "random_effects").} +#' \item{\code{distribution_type}:}{The type of distribution (e.g., +#' "Data", "process"), where a process distribution can refer to a +#' fixed effect or a random effect but it does not fit to data, e.g., +#' recruitment deviations.} +#' \item{\code{distribution}:}{The name of distribution (e.g., +#' "Dlnorm", `Dmultinom`). The column will always be written in +#' PascalCase to match the names used in the C++ code.} +#' } +#' } +#' } +#' @source \url{www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison} +"parameters_big" + +#' FIMS fit +#' +#' An object of class `FIMSFit`, where the structure is the same +#' regardless if `optimize = TRUE` or not. Uncertainty information is only +#' included in the `estimates` slot if `get_sd = TRUE`. +#' +#' @format +#' An object of class `FIMSFit` with the following slots: +#' `r paste(slotNames(fit_with_optimization_big), collapse = ", ")` +#' @rdname fit_with_optimization_big +"fit_with_optimization_big" + +#' @rdname fit_with_optimization_big +"fit_without_optimization_big" + +#' FIMS estimates +#' +#' A tibble containing the estimates from a fitted FIMS model. The structure is +#' the same regardless if `optimize = TRUE` or not. Uncertainty information is +#' only included if `get_sd = TRUE`. +#' @format +#' A tibble with `r NROW(estimates_with_optimization_big)` +#' observations of `r NCOL(estimates_with_optimization_big)` variables: +#' `r paste(colnames(estimates_with_optimization_big), collapse = ", ")` +#' @rdname estimates_with_optimization_big +"estimates_with_optimization_big" + +#' @rdname estimates_with_optimization_big +"estimates_without_optimization_big" diff --git a/R/fimsframe.R b/R/fimsframe.R index 5bcff453e..8f4ac74e7 100644 --- a/R/fimsframe.R +++ b/R/fimsframe.R @@ -686,11 +686,11 @@ methods::setValidity( present_types <- unique(object@data[["type"]]) # Issues warning if there are any unrecognized types - unknown_types <- sort(setdiff(present_types, fims_input_types)) + unknown_types <- sort(setdiff(present_types, FIMS::fims_input_types)) if (length(unknown_types) > 0) { cli::cli_warn(c( "!" = "Data contains unexpected type{?s}: {.var {unknown_types}}.", - "i" = "Allowed types are: {.var {fims_input_types}}.", + "i" = "Allowed types are: {.var {FIMS::fims_input_types}}.", "i" = "Model will run but check that data types are correct." )) } diff --git a/data-raw/data_big.R b/data-raw/data_big.R index 20f7ae332..6c39c0099 100644 --- a/data-raw/data_big.R +++ b/data-raw/data_big.R @@ -34,6 +34,9 @@ check_ASSAMC <- function() { return(TRUE) } +# Ensure usethis points to the package root directory +usethis::proj_set(".", force = TRUE) + check_ASSAMC() library(dplyr) @@ -225,6 +228,7 @@ for (iter in 1:sim_num) { } # Save all simulations to a single file for {testthat} integration tests +dir.create(testthat::test_path("fixtures"), recursive = TRUE, showWarnings = FALSE) save( om_input_list, om_output_list, em_input_list, file = testthat::test_path("fixtures", "integration_test_data.RData") @@ -402,8 +406,131 @@ save( # Add the conversion matrix and length composition data to dataframe data_big <- rbind(data_big, length_comp_data, length_age_data) +fims_frame <- FIMS::FIMSFrame(data_big) + +# Create default parameters for big data +default_parameters <- FIMS::create_default_configurations( + data = fims_frame +) |> + FIMS::create_default_parameters( + data = fims_frame + ) + +# Update the default parameters with values from the OM +om_input <- returned_om[["om_input"]] +om_output <- returned_om[["om_output"]] +em_input <- returned_om[["em_input"]] + +parameters_big <- default_parameters |> + tidyr::unnest(cols = data) |> + # Update log_Fmort input values for Fleet1 + dplyr::rows_update( + tibble::tibble( + fleet = "fleet1", + label = "log_Fmort", + time = 1:FIMS::get_n_years(data_big), + value = log(om_output[["f"]]), + ), + by = c("fleet", "label", "time") + ) |> + # Update selectivity parameters and log_q for survey1 + dplyr::rows_update( + tibble::tibble( + fleet = "survey1", + label = c("inflection_point", "slope", "log_q"), + value = c(1.5, 2, log(om_output[["survey_q"]][["survey1"]])) + ), + by = c("fleet", "label") + ) |> + # Update log_devs in the Recruitment module (time steps 2–30) + dplyr::rows_update( + tibble::tibble( + label = "log_devs", + time = 2:FIMS::get_n_years(data_big), + value = om_input[["logR.resid"]][-1] + ), + by = c("label", "time") + ) |> + # Update log_sd for log_devs in the Recruitment module + # Note: logR_sd is the standard deviation on the natural scale of the + # log recruitment deviations. We take the log of it to match the + # parameterization in the model, which expects a log-transformed + # parameter value. + dplyr::rows_update( + tibble::tibble( + module_name = "Recruitment", + label = "log_sd", + value = log(om_input[["logR_sd"]]) + ), + by = c("module_name", "label") + ) |> + # Update inflection point and slope parameters in the Maturity module + dplyr::rows_update( + tibble::tibble( + module_name = "Maturity", + label = c("inflection_point", "slope"), + value = c( + om_input[["A50.mat"]], + om_input[["slope.mat"]] + ) + ), + by = c("module_name", "label") + ) |> + # Update log_init_naa values in the Population module + dplyr::rows_update( + tibble::tibble( + label = "log_init_naa", + age = 1:FIMS::get_n_ages(data_big), + value = log(om_output[["N.age"]][1, ]) + ), + by = c("label", "age") + ) + +# Fit the model using the big data set and the updated parameters without optimization +fit_without_optimization_big <- parameters_big |> + FIMS::initialize_fims( + data = fims_frame + ) |> + FIMS::fit_fims( + optimize = FALSE + ) + +# Get estimates from the fitted model without optimization +estimates_without_optimization_big <- FIMS::get_estimates( + fit_without_optimization_big +) + +# Fit the model using the big data set and the updated parameters with optimization enabled +fit_with_optimization_big <- parameters_big |> + FIMS::initialize_fims( + data = fims_frame + ) |> + FIMS::fit_fims(optimize = TRUE) + +# Get estimates from the fitted model with optimization +estimates_with_optimization_big <- FIMS::get_estimates( + fit_with_optimization_big +) + +# TODO: remove the line below after updating fit_fims() to not save the +# covariance matrix +fit_with_optimization_big@sdreport$cov <- list(NULL) +fit_with_optimization_big@sdreport$cov.fixed <- list(NULL) + +# Save the big data set, parameters, fitted models, and estimates to the +# package's data directory +usethis::use_data( + data_big, + parameters_big, + fit_without_optimization_big, + estimates_without_optimization_big, + fit_with_optimization_big, + estimates_with_optimization_big, + overwrite = TRUE, + compress = "xz" +) -usethis::use_data(data_big, overwrite = TRUE) +# Clean up temporary files and reset working directory on.exit(unlink(main_dir, recursive = TRUE), add = TRUE) on.exit(setwd(working_dir), add = TRUE) rm(list = ls()) diff --git a/data/data_big.rda b/data/data_big.rda index 6c58492a9..216059cd3 100644 Binary files a/data/data_big.rda and b/data/data_big.rda differ diff --git a/data/estimates_with_optimization_big.rda b/data/estimates_with_optimization_big.rda new file mode 100644 index 000000000..0506cc81c Binary files /dev/null and b/data/estimates_with_optimization_big.rda differ diff --git a/data/estimates_without_optimization_big.rda b/data/estimates_without_optimization_big.rda new file mode 100644 index 000000000..0a6a20a65 Binary files /dev/null and b/data/estimates_without_optimization_big.rda differ diff --git a/data/fims_input_types.rda b/data/fims_input_types.rda index 7c6dee147..e500513bc 100644 Binary files a/data/fims_input_types.rda and b/data/fims_input_types.rda differ diff --git a/data/fit_with_optimization_big.rda b/data/fit_with_optimization_big.rda new file mode 100644 index 000000000..f95bf64d3 Binary files /dev/null and b/data/fit_with_optimization_big.rda differ diff --git a/data/fit_without_optimization_big.rda b/data/fit_without_optimization_big.rda new file mode 100644 index 000000000..dda672ce8 Binary files /dev/null and b/data/fit_without_optimization_big.rda differ diff --git a/data/parameters_big.rda b/data/parameters_big.rda new file mode 100644 index 000000000..e28dbc6e9 Binary files /dev/null and b/data/parameters_big.rda differ diff --git a/man/data_big.Rd b/man/data_big.Rd index 2702a9621..e11cb4346 100644 --- a/man/data_big.Rd +++ b/man/data_big.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_.R +% Please edit documentation in R/data_big.R \docType{data} \name{data_big} \alias{data_big} diff --git a/man/estimates_with_optimization_big.Rd b/man/estimates_with_optimization_big.Rd new file mode 100644 index 000000000..bc2fb866c --- /dev/null +++ b/man/estimates_with_optimization_big.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_big.R +\docType{data} +\name{estimates_with_optimization_big} +\alias{estimates_with_optimization_big} +\alias{estimates_without_optimization_big} +\title{FIMS estimates} +\format{ +A tibble with 13996 +observations of 24 variables: +module_name, module_id, module_type, label, type, type_id, parameter_id, fleet, year_i, age_i, length_i, input, estimated, expected, observed, estimation_type, uncertainty, distribution, input_type, lpdf, likelihood, log_sd, log_like_cv, gradient + +An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 13996 rows and 24 columns. +} +\usage{ +estimates_with_optimization_big + +estimates_without_optimization_big +} +\description{ +A tibble containing the estimates from a fitted FIMS model. The structure is +the same regardless if \code{optimize = TRUE} or not. Uncertainty information is +only included if \code{get_sd = TRUE}. +} +\keyword{datasets} diff --git a/man/fit_with_optimization_big.Rd b/man/fit_with_optimization_big.Rd new file mode 100644 index 000000000..f30159996 --- /dev/null +++ b/man/fit_with_optimization_big.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_big.R +\docType{data} +\name{fit_with_optimization_big} +\alias{fit_with_optimization_big} +\alias{fit_without_optimization_big} +\title{FIMS fit} +\format{ +An object of class \code{FIMSFit} with the following slots: +input, obj, opt, max_gradient, gradient, report, sdreport, number_of_parameters, timing, version, model_output + +An object of class \code{FIMSFit} of length 1. +} +\usage{ +fit_with_optimization_big + +fit_without_optimization_big +} +\description{ +An object of class \code{FIMSFit}, where the structure is the same +regardless if \code{optimize = TRUE} or not. Uncertainty information is only +included in the \code{estimates} slot if \code{get_sd = TRUE}. +} +\keyword{datasets} diff --git a/man/parameters_big.Rd b/man/parameters_big.Rd new file mode 100644 index 000000000..d33ddefef --- /dev/null +++ b/man/parameters_big.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_big.R +\docType{data} +\name{parameters_big} +\alias{parameters_big} +\title{FIMS parameters tibble} +\format{ +A tibble with 538 observations of 12 variables: +\describe{ +\item{\code{model_family}:}{The specified model family (e.g., +"catch_at_age").} +\item{\code{module_name}:}{The name of the FIMS module (e.g., +"Data", "Selectivity", "Recruitment", "Growth", "Maturity"). These +entries are always written in PascalCase to match the names used in the +C++ code.} +\item{\code{fleet}:}{The name of the fleet the module applies to. This +will be \code{NA} for non-fleet-specific modules like "Recruitment".} +\item{\code{data}:}{A list-column containing a \code{tibble} with detailed +parameters. Unnesting this column reveals: +\describe{ +\item{\code{module_type}:}{The specific type of the module (e.g., +"Logistic" for a "Selectivity" module). This column will always be +written in PascalCase to match the names used in the C++ code.} +\item{\code{label}:}{The name of the parameter (e.g., +"inflection_point").} +\item{\code{age}:}{The age the parameter applies to.} +\item{\code{length}:}{The length bin the parameter applies to.} +\item{\code{time}:}{The time step (i.e., year) the parameter applies +to.} +\item{\code{value}:}{The initial value of the parameter.} +\item{\code{estimation_type}:}{The type of estimation (e.g., +"constant", "fixed_effects", "random_effects").} +\item{\code{distribution_type}:}{The type of distribution (e.g., +"Data", "process"), where a process distribution can refer to a +fixed effect or a random effect but it does not fit to data, e.g., +recruitment deviations.} +\item{\code{distribution}:}{The name of distribution (e.g., +"Dlnorm", \code{Dmultinom}). The column will always be written in +PascalCase to match the names used in the C++ code.} +} +} +} +} +\source{ +\url{www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison} +} +\usage{ +parameters_big +} +\description{ +A tibble containing the parameters needed to run an age-structured stock +assessment model in FIMS. This data was generated using the \code{ASSAMC} package +written for the \href{www.github.com/NOAA-FIMS/Age_Structured_Stock_Assessment_Model_Comparison}{model comparison project}. +The source code to make this dataset is in \code{data-raw/parameters_.R} which is +on GitHub but will not be in your local installation because it is in the .Rbuildignore file. +} +\keyword{datasets} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index f0bbd1eb5..883c681a6 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -25,7 +25,7 @@ reference: desc: > Example dataset used in FIMS demonstrations and examples. contents: - - data_big + - ends_with("_big") - fims_input_types - title: Run FIMS diff --git a/tests/README.md b/tests/README.md index 1b2d5742c..b457bcae8 100644 --- a/tests/README.md +++ b/tests/README.md @@ -24,6 +24,7 @@ Prepare the test data in the new file or in a separate file if you plan on reusi } ``` - Use pre-existing integration data, e.g., `tests/testthat/fixtures/integration_test_data_components.RData` and `tests/testthat/fixtures/integration_test_data.RData`, by loading them within the `setup` section, e.g., `load(testthat::test_path("fixtures", "integration_test_data.RData"))` or within `prepare_test_data()`, where these data objects can be updated by running `R/data_big.R`. +- Use pre-existing package data, e.g., `FIMS::data_big`, `FIMS::parameters_big`, `FIMS::fit_with_optimization_big`, and `FIMS::estimates_with_optimization_big`, by loading them within the `setup` section, e.g., `data("data_big", package = "FIMS")`. If those data objects need to be updated because of changes in the core code, run `R/data_big.R` to update them. ### :pencil: Edit the code in the new test file @@ -75,6 +76,7 @@ The following {testthat} functions can be used at the beginning of a test file t - Add [`testthat::skip_on_ci()`](https://testthat.r-lib.org/reference/skip.html) at the beginning of a test file to skip it during continuous integration runs. - Add [`testthat::skip_on_covr()`](https://testthat.r-lib.org/reference/skip.html) at the beginning of a test file to skip it during coverage calculation. +- Add `testthat::skip_if_not(testthat:::env_var_is_true("RUN_SLOW_TESTS"), message = "Skipping: RUN_SLOW_TESTS is not set to true.")` at the beginning of a test file to skip it unless the environment variable `RUN_SLOW_TESTS` is set to true. This is useful for integration tests that take a long time to run and are not needed for every test run locally. The slow tests will be run on GitHub Actions when submitting a pull request to the main branch. If you need to run the slow tests locally, set the environment variable `RUN_SLOW_TESTS` to true before running the tests, e.g., `Sys.setenv(RUN_SLOW_TESTS = "true")` in R. #### :mute: Suppressing messages diff --git a/tests/testthat/_snaps/get_estimates.md b/tests/testthat/_snaps/get_estimates.md index 2b8531316..5188e960c 100644 --- a/tests/testthat/_snaps/get_estimates.md +++ b/tests/testthat/_snaps/get_estimates.md @@ -1,8 +1,9 @@ -# `get_estimates()` works with deterministic run +# precomputed estimates_without_optimization_big has expected structure Code - print(dplyr::select(get_estimates(deterministic_results), -estimated, -expected, - -uncertainty, -gradient, -likelihood, -log_like_cv, -gradient), n = 320, width = Inf) + print(dplyr::select(estimates_without_optimization_big, -estimated, -expected, + -uncertainty, -gradient, -likelihood, -log_like_cv, -gradient), n = 320, + width = Inf) Output # A tibble: 13,996 x 18 module_name module_id module_type label type type_id @@ -976,8 +977,8 @@ # `get_estimates()` works with estimation run Code - print(dplyr::select(get_estimates(readRDS(fit_files[[1]])), -estimated, - -expected, -uncertainty, -gradient, -likelihood, -log_like_cv, -gradient), n = 320, + print(dplyr::select(estimates_with_optimization_big, -estimated, -expected, + -uncertainty, -gradient, -likelihood, -log_like_cv, -gradient), n = 320, width = Inf) Output # A tibble: 13,996 x 18 diff --git a/tests/testthat/fixtures/integration_test_data.RData b/tests/testthat/fixtures/integration_test_data.RData index 974e99181..57c160b83 100644 Binary files a/tests/testthat/fixtures/integration_test_data.RData and b/tests/testthat/fixtures/integration_test_data.RData differ diff --git a/tests/testthat/fixtures/integration_test_data_components.RData b/tests/testthat/fixtures/integration_test_data_components.RData index ff6df14d6..f2e98a2e9 100644 Binary files a/tests/testthat/fixtures/integration_test_data_components.RData and b/tests/testthat/fixtures/integration_test_data_components.RData differ diff --git a/tests/testthat/helper-aaa-prompt-to-update-data.R b/tests/testthat/helper-aaa-prompt-to-update-data.R new file mode 100644 index 000000000..f91d6f08d --- /dev/null +++ b/tests/testthat/helper-aaa-prompt-to-update-data.R @@ -0,0 +1,11 @@ +# Helper script to prompt developer to update *_big dataset if relevant code has been modified + +if (interactive()) { + cli::cli_alert_warning( + "Did you modify code affecting {.var data_big} generation, parameter setup, model fitting, or {.fn get_estimates}?" + ) + + cli::cli_alert_info( + "If yes, run `source(file.path('data-raw', 'data_big.R'))` to update the dataset." + ) +} diff --git a/tests/testthat/test-create_default_configurations.R b/tests/testthat/test-create_default_configurations.R index 0409df870..862479ae8 100644 --- a/tests/testthat/test-create_default_configurations.R +++ b/tests/testthat/test-create_default_configurations.R @@ -52,57 +52,49 @@ test_that("`create_default_configurations()` works with correct inputs", { }) ## Edge handling ---- -# Please remove/comment out the test template below if no edge cases are being tested. -test_that("`create_default_configurations()` returns correct outputs for edge cases", { - # Load the test data from an RDS file containing model fits. - if (!file.exists(testthat::test_path("fixtures", "data_length_comp.RDS"))) { - prepare_test_data() - } - - # List all RDS files in the fixtures directory that match the pattern "data*_.RDS" - data_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^data.*\\.RDS$", - full.names = TRUE +test_that("`create_default_configurations()` handles edge-case inputs", { + default_configurations_unnested <- create_default_configurations(data_age_length) |> + tidyr::unnest(cols = data) + + reordered_data <- data_big |> + dplyr::arrange(dplyr::desc(.data$timing), .data$fleet, .data$type, .data$age, .data$length) + reordered_frame <- FIMSFrame(reordered_data) + reordered_configurations <- create_default_configurations(reordered_frame) |> + tidyr::unnest(cols = data) + + #' @description Test that reordering input rows does not change the generated module configuration table. + expect_equal( + object = reordered_configurations, + expected = default_configurations_unnested ) - # Function to read the RDS file, get fits, and check column names - check_colnames <- function(data_file) { - data <- readRDS(data_file) - configurations <- create_default_configurations(data) |> - tidyr::unnest(cols = data) - expected_names <- colnames(configurations) - #' @description Test that configurations for various special data cases have the correct column structure. - expect_equal( - object = colnames(configurations), - expected = expected_names + mock_additional_fleet <- data_big |> + dplyr::filter( + .data$fleet == "fleet1", + .data$type %in% c("landings", "age_comp", "length_comp") + ) |> + dplyr::mutate(fleet = "fleet_mock") + + mock_data <- dplyr::bind_rows(data_big, mock_additional_fleet) + mock_frame <- FIMSFrame(mock_data) + mock_configurations <- create_default_configurations(mock_frame) |> + tidyr::unnest(cols = data) + + #' @description Test that adding a new fleet with supported data types adds fleet-specific data and selectivity modules. + expect_true( + any( + mock_configurations[["module_name"]] == "Selectivity" & + mock_configurations[["fleet"]] == "fleet_mock" ) + ) - if (data_file == testthat::test_path("fixtures", "data_age_comp_na.RDS")) { - module_types <- configurations |> - dplyr::pull(module_type) |> - unique() - #' @description Test that for data containing only age information, the `AgeComp` module is correctly included. - expect_true("AgeComp" %in% module_types) - - #' @description Test that for data containing only age information, the `LengthComp` module is correctly excluded. - expect_true(!("LengthComp" %in% module_types)) - } - - if (data_file == testthat::test_path("fixtures", "data_length_comp_na.RDS")) { - module_types <- configurations |> - dplyr::pull(module_type) |> - unique() - #' @description Test that for data containing only length information, the `LengthComp` module is correctly included. - expect_true("LengthComp" %in% module_types) - - #' @description Test that for data containing only length information, the `AgeComp` module is correctly excluded. - expect_true(!("AgeComp" %in% module_types)) - } - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(data_files, check_colnames) + #' @description Test that adding a new fleet with supported data types creates only the expected fleet-specific data module types. + expect_setequal( + object = mock_configurations |> + dplyr::filter(.data$fleet == "fleet_mock", .data$module_name == "Data") |> + dplyr::pull(.data$module_type), + expected = c("Landings", "AgeComp", "LengthComp") + ) }) ## Error handling ---- diff --git a/tests/testthat/test-fimsfit.R b/tests/testthat/test-fimsfit.R index 8a573ed86..a5e352117 100644 --- a/tests/testthat/test-fimsfit.R +++ b/tests/testthat/test-fimsfit.R @@ -9,25 +9,33 @@ # FIMSFit ---- ## Setup ---- -# Load the test data from an RDS file containing the fitted model estimates -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - suppressWarnings( - suppressMessages( - prepare_test_data() - ) +# Load the test data +data_big <- FIMSFrame(FIMS::data_big) +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + +## IO correctness ---- +test_that("`is.FIMSFit()` works with fit with optimization", { + #' @description Test that `is.FIMSFit(fit_with_optimization_big)` returns TRUE. + expect_true( + object = is.FIMSFit(fit_with_optimization_big) ) -} -fit_age_length_comp <- readRDS(testthat::test_path("fixtures", "fit_age_length_comp.RDS")) -fit_agecomp <- readRDS(testthat::test_path("fixtures", "fit_agecomp.RDS")) -fit_list <- list(fit_age_length_comp, fit_agecomp) -on.exit(rm(fit_list), add = TRUE) + expected_names <- c( + "input", "obj", "opt", "max_gradient", "gradient", "report", "sdreport", + "number_of_parameters", "timing", "version", "model_output" + ) + #' @description Test a FIMSFit object has the correct slot names. + expect_equal( + object = slotNames(fit_with_optimization_big), + expected = expected_names + ) +}) -## IO correctness ---- -test_that("`is.FIMSFit()` works with correct inputs", { - #' @description Test that `is.FIMSFit(fit_age_length_comp)` returns TRUE. +test_that("`is.FIMSFit()` works with fit without optimization", { + #' @description Test that `is.FIMSFit(fit_without_optimization_big)` returns TRUE. expect_true( - object = is.FIMSFit(fit_age_length_comp) + object = is.FIMSFit(fit_without_optimization_big) ) expected_names <- c( @@ -36,7 +44,7 @@ test_that("`is.FIMSFit()` works with correct inputs", { ) #' @description Test a FIMSFit object has the correct slot names. expect_equal( - object = slotNames(fit_age_length_comp), + object = slotNames(fit_without_optimization_big), expected = expected_names ) }) @@ -47,25 +55,35 @@ test_that("`is.FIMSFit()` returns correct outputs for edge cases", { expect_false(is.FIMSFit("not_a_FIMSFit")) # Modify the total time to be more than a day - fit_age_length_comp@timing[["time_total"]] <- 86401 # 60*60*24+1 + fit_with_optimization_big@timing[["time_total"]] <- 86401 # 60*60*24+1 #' @description Test that `print(FIMSFit)` returns no error when the total time is more than a day. - expect_no_error(print(fit_age_length_comp)) + expect_no_error(print(fit_with_optimization_big)) # Modify the total time to be more than a hour - fit_age_length_comp@timing[["time_total"]] <- 3601 # 60*60+1 + fit_with_optimization_big@timing[["time_total"]] <- 3601 # 60*60+1 #' @description Test that `print(FIMSFit)` returns no error when the total time is more than an hour. - expect_no_error(print(fit_age_length_comp)) + expect_no_error(print(fit_with_optimization_big)) # Modify the total time to be more than a minute - fit_age_length_comp@timing[["time_total"]] <- 61 # 60+1 + fit_with_optimization_big@timing[["time_total"]] <- 61 # 60+1 #' @description Test that `print(FIMSFit)` returns no error when the total time is more than a minute. - expect_no_error(print(fit_age_length_comp)) + expect_no_error(print(fit_with_optimization_big)) + + #' @description Test that `fit_without_optimization_big` has a total time of 0 seconds. + expect_equal( + object = fit_without_optimization_big@timing[["time_total"]], + expected = 0 + ) }) ## Error handling ---- test_that("fit_fims() errors when optimization fails to converge", { # Create a simple test case that will fail to converge by setting # extremely restrictive iteration limits + testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." + ) # Skip if test fixtures don't exist skip_if_not(file.exists(testthat::test_path("fixtures", "integration_test_data.RData"))) @@ -73,13 +91,10 @@ test_that("fit_fims() errors when optimization fails to converge", { load(testthat::test_path("fixtures", "integration_test_data.RData")) # Set up the model with data - data_age_comp <- FIMSFrame(data_big) - parameters <- readRDS( - testthat::test_path("fixtures", "parameters_model_comparison_project.RDS") - ) + parameters <- FIMS::parameters_big initialized_model <- parameters |> - initialize_fims(data = data_age_comp) + initialize_fims(data = data_big) # Set control parameters that will cause convergence failure # by making iteration limits extremely low @@ -131,7 +146,7 @@ test_that("fit_fims() errors when optimization fails to converge", { dplyr::rows_update( tibble::tibble( label = "log_devs", - time = 2:get_n_years(data_age_comp), + time = 2:get_n_years(data_big), estimation_type = "fixed_effects" ), by = c("label", "time") @@ -148,14 +163,14 @@ test_that("fit_fims() errors when optimization fails to converge", { tibble::tibble( module_type = "Landings", label = "log_sd", - time = 1:get_n_years(data_age_comp), + time = 1:get_n_years(data_big), value = 10 ), by = c("module_type", "label", "time") ) initialized_model <- parameters_4_model |> - initialize_fims(data = data_age_comp) + initialize_fims(data = data_big) #' @description Test that fit_fims() throws an informative warning when parameter SE values are too large. expect_warning( @@ -170,7 +185,7 @@ test_that("fit_fims() errors when optimization fails to converge", { dplyr::rows_update( tibble::tibble( label = "log_devs", - time = 2:get_n_years(data_age_comp), + time = 2:get_n_years(data_big), estimation_type = "fixed_effects" ), by = c("label", "time") @@ -193,7 +208,7 @@ test_that("fit_fims() errors when optimization fails to converge", { ) initialized_model <- parameters_4_model |> - initialize_fims(data = data_age_comp) + initialize_fims(data = data_big) #' @description Test that fit_fims() throws an informative warning when parameter SE values are NA. expect_warning( @@ -215,7 +230,7 @@ test_that("fit_fims() errors when optimization fails to converge", { ) initialized_model <- parameters_4_model |> - initialize_fims(data = data_age_comp) + initialize_fims(data = data_big) #' @description Test that fit_fims() throws an informative warning when the Hessian is not positive definite. expect_warning( @@ -224,11 +239,9 @@ test_that("fit_fims() errors when optimization fails to converge", { ) #' @description Test that fit_fims() returns a non-converged model when you know it is not supposed to converge. The warnings and messages are suppressed because {nlminb} uses backend code that we do not want to print to the screen during testing but we know will be there. - data("data_big", package = "FIMS") - data_4_model <- FIMSFrame(data_big) # Create parameters - initialized_poor_model <- create_default_configurations(data_4_model) |> - create_default_parameters(data = data_4_model) |> + initialized_poor_model <- create_default_configurations(data_big) |> + create_default_parameters(data = data_big) |> tidyr::unnest(cols = data) |> dplyr::rows_update( tibble::tibble( @@ -239,7 +252,7 @@ test_that("fit_fims() errors when optimization fails to converge", { ), by = c("module_name", "label", "age") ) |> - initialize_fims(data = data_4_model) + initialize_fims(data = data_big) test_results <- suppressWarnings(suppressMessages( fit_fims(initialized_poor_model, optimize = TRUE) )) diff --git a/tests/testthat/test-fimsframe.R b/tests/testthat/test-fimsframe.R index f42f6fa86..0fffe5bb7 100644 --- a/tests/testthat/test-fimsframe.R +++ b/tests/testthat/test-fimsframe.R @@ -9,7 +9,7 @@ # fims_frame ---- ## Setup ---- -data("data_big", "fims_input_types", package = "FIMS") +data_big <- FIMS::data_big fims_frame <- FIMS::FIMSFrame(data_big) # A helper function that creates a figure from code @@ -299,7 +299,6 @@ test_that("`FIMSFrame()` returns correct error messages", { # model_* ---- ## Setup ---- -fims_frame <- FIMS::FIMSFrame(data_big) n_years <- get_n_years(fims_frame) n_ages <- get_n_ages(fims_frame) @@ -439,31 +438,9 @@ test_that("`model_*()` returns correct error messages", { ## Setup ---- # Load the test data from an RDS file containing model fits. # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" -if (!file.exists(testthat::test_path("fixtures", "data_age_comp.RDS"))) { - prepare_test_data() -} - -data_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^data.*\\.RDS$", - full.names = TRUE -) - ## IO correctness ---- test_that("`get_n_fleets()` works with correct inputs", { - # Function to read the RDS file and get input - check_input <- function(data_file) { - data <- readRDS(data_file) - n_fleets <- get_n_fleets(data) - #' @description Test that `get_n_fleets()` returns correct number of fleets. - expect_equal( - object = n_fleets, - expected = 2 - ) - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(data_files, check_input) + expect_equal(get_n_fleets(fims_frame), 2) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_estimates.R b/tests/testthat/test-get_estimates.R index 6374e3fee..c4bcd2eb2 100644 --- a/tests/testthat/test-get_estimates.R +++ b/tests/testthat/test-get_estimates.R @@ -10,9 +10,8 @@ # get_estimates ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +estimates_with_optimization_big <- FIMS::estimates_with_optimization_big +estimates_without_optimization_big <- FIMS::estimates_without_optimization_big ## IO correctness ---- # Define the expected column names for the estimates tibble @@ -25,10 +24,8 @@ expected_colnames <- c( "lpdf", "likelihood", "log_sd", "log_like_cv", "gradient" ) -test_that("`get_estimates()` works with deterministic run", { - # Read the RDS file containing the deterministic run results - deterministic_results <- readRDS(testthat::test_path("fixtures", "deterministic_age_length_comp.RDS")) - deterministic_colnames <- get_estimates(deterministic_results) |> colnames() +test_that("precomputed estimates_without_optimization_big has expected structure", { + deterministic_colnames <- colnames(estimates_without_optimization_big) #' @description Test that `get_estimates()` returns correct colnames from a deterministic run. expect_equal( object = deterministic_colnames, @@ -37,7 +34,7 @@ test_that("`get_estimates()` works with deterministic run", { #' @description Test that the result values from the model fit have not changed from the accepted version. expect_snapshot( - get_estimates(deterministic_results) |> + estimates_without_optimization_big |> # Remove the estimate, uncertainty, and gradient columns, as they # may change between runs dplyr::select( @@ -49,35 +46,17 @@ test_that("`get_estimates()` works with deterministic run", { }) test_that("`get_estimates()` works with estimation run", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE + get_estimates_colnames <- colnames(estimates_with_optimization_big) + #' @description Test that `get_estimates()` returns correct colnames from an estimation run. + expect_equal( + object = get_estimates_colnames, + expected = expected_colnames ) - # Function to read the RDS file, get estimates, and check column names - check_estimates_colnames <- function(fit_file) { - fit_data <- readRDS(fit_file) - estimates <- get_estimates(fit_data) - estimates_colnames <- colnames(estimates) - - #' @description Test that `get_estimates()` returns correct colnames from a estimation run. - expect_equal( - object = estimates_colnames, - expected = expected_colnames - ) - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_estimates_colnames) - #' @description Test that the result values from the model fit have not changed from the accepted version. expect_snapshot( # Read the first RDS file, get estimates, and print a snapshot - readRDS(fit_files[[1]]) |> - get_estimates() |> + estimates_with_optimization_big |> # Remove the estimated, uncertainty, and gradient columns, as they # may change between runs dplyr::select( diff --git a/tests/testthat/test-get_input.R b/tests/testthat/test-get_input.R index 3d96cac9b..80a2772da 100644 --- a/tests/testthat/test-get_input.R +++ b/tests/testthat/test-get_input.R @@ -10,38 +10,36 @@ # get_input ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big ## IO correctness ---- test_that("`get_input()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE + input_with_optimization <- get_input(fit_with_optimization_big) + #' @description Test that `get_input()` returns correct values for the `input` slot. + expect_equal( + object = input_with_optimization, + expected = fit_with_optimization_big@input ) - # Function to read the RDS file and get input - check_input <- function(fit_file) { - fit_data <- readRDS(fit_file) - input <- get_input(fit_data) - #' @description Test that `get_input()` returns correct output for the `input` slot. - expect_equal( - object = input, - expected = fit_data@input - ) - #' @description Test that `get_input()` returns correct names for the `input` slot. - expect_equal( - object = names(input), - expected = c("parameters", "model") - ) - } + #' @description Test that `get_input()` returns correct names for the `input` slot. + expect_equal( + object = names(input_with_optimization), + expected = c("parameters", "model") + ) + + #' @description Test that `get_input()` returns correct values for the `input` slot. + input_without_optimization <- get_input(fit_without_optimization_big) + expect_equal( + object = input_without_optimization, + expected = fit_without_optimization_big@input + ) - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_input) + #' @description Test that `get_input()` returns correct names for the `input` slot. + expect_equal( + object = names(input_without_optimization), + expected = c("parameters", "model") + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_max_gradient.R b/tests/testthat/test-get_max_gradient.R index 4f8a10d6f..c96741b63 100644 --- a/tests/testthat/test-get_max_gradient.R +++ b/tests/testthat/test-get_max_gradient.R @@ -10,37 +10,34 @@ # get_max_gradient ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + ## IO correctness ---- test_that("`get_max_gradient()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE + max_gradient_with_optimization <- get_max_gradient(fit_with_optimization_big) + #' @description Test that `get_max_gradient()` returns correct output for the `max_gradient` slot. + expect_equal( + object = max_gradient_with_optimization, + expected = fit_with_optimization_big@max_gradient ) - # Function to read the RDS file and get max gradient - check_max_gradient <- function(fit_file) { - fit_data <- readRDS(fit_file) - max_gradient <- get_max_gradient(fit_data) - #' @description Test that `get_max_gradient()` returns correct output for the `max_gradient` slot. - expect_equal( - object = max_gradient, - expected = fit_data@max_gradient - ) + #' @description Test that `get_max_gradient()` returns a numeric value. + expect_true( + object = is.numeric(max_gradient_with_optimization) + ) - #' @description Test that `get_max_gradient()` returns a numeric value. - expect_true( - object = is.numeric(max_gradient) - ) - } + max_gradient_without_optimization <- get_max_gradient(fit_without_optimization_big) + #' @description Test that `get_max_gradient()` returns correct output for the `max_gradient` slot. + expect_equal( + object = max_gradient_without_optimization, + expected = fit_without_optimization_big@max_gradient + ) - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_max_gradient) + #' @description Test that `get_max_gradient()` returns NA. + expect_true( + object = is.na(max_gradient_without_optimization) + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_model_output.R b/tests/testthat/test-get_model_output.R index ed8d475fa..dd44ac49e 100644 --- a/tests/testthat/test-get_model_output.R +++ b/tests/testthat/test-get_model_output.R @@ -10,21 +10,11 @@ # get_model_output ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big ## IO correctness ---- test_that("`get_model_output()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - # or "deterministic*.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^(fit.*|deterministic.*)\\.RDS$", - full.names = TRUE - ) - expected_names <- c( "name", "type", "estimation_framework", "id", "objective_function_value", "growth", "recruitment", "maturity", @@ -32,20 +22,21 @@ test_that("`get_model_output()` works with correct inputs", { "density_components", "data" ) - # Function to read the RDS file and get obj - check_obj <- function(fit_file) { - fit_data <- readRDS(fit_file) - model_output <- get_model_output(fit_data) - json_list <- jsonlite::fromJSON(model_output, simplifyVector = FALSE) - #' @description Test that `get_model_output()` returns correct names for the `model_output` slot. - expect_equal( - object = names(json_list), - expected = expected_names - ) - } + model_output_with_optimization <- get_model_output(fit_with_optimization_big) + json_list_with_optimization <- jsonlite::fromJSON(model_output_with_optimization, simplifyVector = FALSE) + #' @description Test that `get_model_output(fit_with_optimization_big)` returns correct names for the `model_output` slot. + expect_equal( + object = names(json_list_with_optimization), + expected = expected_names + ) - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_obj) + model_output_without_optimization <- get_model_output(fit_without_optimization_big) + json_list_without_optimization <- jsonlite::fromJSON(model_output_without_optimization, simplifyVector = FALSE) + #' @description Test that `get_model_output(fit_without_optimization_big)` returns correct names for the `model_output` slot. + expect_equal( + object = names(json_list_without_optimization), + expected = expected_names + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_number_parameters.R b/tests/testthat/test-get_number_parameters.R index dc1d1d94c..034db5383 100644 --- a/tests/testthat/test-get_number_parameters.R +++ b/tests/testthat/test-get_number_parameters.R @@ -10,44 +10,50 @@ # get_number_of_parameters ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + ## IO correctness ---- -test_that("`get_number_of_parameters()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE +test_that("`get_number_of_parameters()` works with fit_with_optimization_big", { + expected_n_total <- length(fit_with_optimization_big@obj[["env"]][["last.par.best"]]) + expected_n_fixed_effects <- length(fit_with_optimization_big@obj[["par"]]) + expected_n_random_effects <- length(fit_with_optimization_big@obj[["env"]]$parList()[["re"]]) + number_of_parameters <- get_number_of_parameters(fit_with_optimization_big) + expected_vector <- c( + fixed_effects = expected_n_fixed_effects, + random_effects = expected_n_random_effects ) + #' @description Test that `get_number_of_parameters()` returns correct output for the `number_of_parameters` slot. + expect_equal( + object = number_of_parameters, + expected = fit_with_optimization_big@number_of_parameters + ) + #' @description Test that `get_number_of_parameters()` returns correct names for the `number_of_parameters` slot. + expect_equal( + object = number_of_parameters, + expected = expected_vector + ) +}) - # Function to read the RDS file and get input - check_number_of_parameters <- function(fit_file) { - fit_data <- readRDS(fit_file) - expected_n_total <- length(fit_data@obj[["env"]][["last.par.best"]]) - expected_n_fixed_effects <- length(fit_data@obj[["par"]]) - expected_n_random_effects <- length(fit_data@obj[["env"]]$parList()[["re"]]) - number_of_parameters <- get_number_of_parameters(fit_data) - expected_vector <- c( - fixed_effects = expected_n_fixed_effects, - random_effects = expected_n_random_effects - ) - #' @description Test that `get_number_of_parameters()` returns correct output for the `number_of_parameters` slot. - expect_equal( - object = number_of_parameters, - expected = fit_data@number_of_parameters - ) - #' @description Test that `get_number_of_parameters()` returns correct names for the `number_of_parameters` slot. - expect_equal( - object = number_of_parameters, - expected = expected_vector - ) - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_number_of_parameters) +test_that("`get_number_of_parameters()` works with fit_without_optimization_big", { + expected_n_total <- length(fit_without_optimization_big@obj[["env"]][["last.par.best"]]) + expected_n_fixed_effects <- length(fit_without_optimization_big@obj[["par"]]) + expected_n_random_effects <- length(fit_without_optimization_big@obj[["env"]]$parList()[["re"]]) + number_of_parameters <- get_number_of_parameters(fit_without_optimization_big) + expected_vector <- c( + fixed_effects = expected_n_fixed_effects, + random_effects = expected_n_random_effects + ) + #' @description Test that `get_number_of_parameters()` returns correct output for the `number_of_parameters` slot. + expect_equal( + object = number_of_parameters, + expected = fit_without_optimization_big@number_of_parameters + ) + #' @description Test that `get_number_of_parameters()` returns correct names for the `number_of_parameters` slot. + expect_equal( + object = number_of_parameters, + expected = expected_vector + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_obj.R b/tests/testthat/test-get_obj.R index 07a6cfd38..5374b9f92 100644 --- a/tests/testthat/test-get_obj.R +++ b/tests/testthat/test-get_obj.R @@ -10,42 +10,45 @@ # get_obj ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + +expected_names <- c( + "par", "fn", "gr", "he", "hessian", "method", "retape", + "env", "report", "simulate" +) + ## IO correctness ---- -test_that("`get_obj()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE +test_that("`get_obj()` works with fit_with_optimization_big", { + obj <- get_obj(fit_with_optimization_big) + + #' @description Test that `get_obj()` returns correct output for the `obj` slot. + expect_equal( + object = obj, + expected = fit_with_optimization_big@obj + ) + + #' @description Test that `get_obj()` returns correct names for the `obj` slot. + expect_equal( + object = names(obj), + expected = expected_names ) +}) - expected_names <- c( - "par", "fn", "gr", "he", "hessian", "method", "retape", - "env", "report", "simulate" +test_that("`get_obj()` works with fit_without_optimization_big", { + obj <- get_obj(fit_without_optimization_big) + + #' @description Test that `get_obj()` returns correct output for the `obj` slot. + expect_equal( + object = obj, + expected = fit_without_optimization_big@obj ) - # Function to read the RDS file and get obj - check_obj <- function(fit_file) { - fit_data <- readRDS(fit_file) - obj <- get_obj(fit_data) - #' @description Test that `get_obj()` returns correct output for the `obj` slot. - expect_equal( - object = obj, - expected = fit_data@obj - ) - #' @description Test that `get_obj()` returns correct names for the `obj` slot. - expect_equal( - object = names(obj), - expected = expected_names - ) - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_obj) + #' @description Test that `get_obj()` returns correct names for the `obj` slot. + expect_equal( + object = names(obj), + expected = expected_names + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_opt.R b/tests/testthat/test-get_opt.R index b1b59e5f7..05152b4e2 100644 --- a/tests/testthat/test-get_opt.R +++ b/tests/testthat/test-get_opt.R @@ -10,42 +10,42 @@ # get_opt ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + +expected_names <- c( + "par", "objective", "convergence", + "iterations", "evaluations", "message" +) + ## IO correctness ---- -test_that("`get_opt()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE +test_that("`get_opt()` works with fit_with_optimization_big", { + opt_with_optimization <- get_opt(fit_with_optimization_big) + #' @description Test that `get_opt()` returns correct output for the `opt` slot. + expect_equal( + object = opt_with_optimization, + expected = fit_with_optimization_big@opt + ) + + #' @description Test that `get_opt()` returns correct names for the `opt` slot. + expect_equal( + object = names(opt_with_optimization), + expected = expected_names ) +}) - expected_names <- c( - "par", "objective", "convergence", - "iterations", "evaluations", "message" +test_that("`get_opt()` works with fit_without_optimization_big", { + opt_without_optimization <- get_opt(fit_without_optimization_big) + #' @description Test that `get_opt()` returns correct output for the `opt` slot. + expect_equal( + object = opt_without_optimization, + expected = fit_without_optimization_big@opt ) - # Function to read the RDS file and get input - check_opt <- function(fit_file) { - fit_data <- readRDS(fit_file) - opt <- get_opt(fit_data) - #' @description Test that `get_opt()` returns correct output for the `opt` slot. - expect_equal( - object = opt, - expected = fit_data@opt - ) - #' @description Test that `get_opt()` returns correct names for the `opt` slot. - expect_equal( - object = names(opt), - expected = expected_names - ) - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_opt) + #' @description Test that `get_opt()` returns an empty list for the `opt` slot when optimization is not performed. + expect_true( + object = is.list(opt_without_optimization) && length(opt_without_optimization) == 0 + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_sdreport.R b/tests/testthat/test-get_sdreport.R index 8825bb000..3447bc92d 100644 --- a/tests/testthat/test-get_sdreport.R +++ b/tests/testthat/test-get_sdreport.R @@ -10,58 +10,41 @@ # get_sdreport ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + +expected_names <- c( + "value", "sd", "cov", "par.fixed", "cov.fixed", "pdHess", + "gradient.fixed", "par.random", "diag.cov.random", "env" +) ## IO correctness ---- -test_that("`get_sdreport()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE +test_that("`get_sdreport()` works with fit_with_optimization_big", { + sdreport_with_optimization <- get_sdreport(fit_with_optimization_big) + #' @description Test that `get_sdreport()` returns correct output for the `sdreport` slot. + expect_equal( + object = sdreport_with_optimization, + expected = fit_with_optimization_big@sdreport ) - - expected_names <- c( - "value", "sd", "cov", "par.fixed", "cov.fixed", "pdHess", - "gradient.fixed", "env" + #' @description Test that `get_sdreport()` returns correct names for the `sdreport` slot. + expect_equal( + object = names(sdreport_with_optimization), + expected = expected_names ) +}) - expected_names_re <- c( - "value", "sd", "cov", "par.fixed", "cov.fixed", - "pdHess", "gradient.fixed", "par.random", "diag.cov.random", "env" +test_that("`get_sdreport()` works with fit_without_optimization_big", { + sdreport_without_optimization <- get_sdreport(fit_without_optimization_big) + #' @description Test that `get_sdreport()` returns correct output for the `sdreport` slot. + expect_equal( + object = sdreport_without_optimization, + expected = fit_without_optimization_big@sdreport + ) + #' @description Test that `get_sdreport()` returns correct names for the `sdreport` slot. + expect_equal( + object = names(sdreport_without_optimization), + expected = NULL ) - - # Function to read the RDS file and get input - check_sdreport <- function(fit_file) { - fit_data <- readRDS(fit_file) - sdreport <- get_sdreport(fit_data) - #' @description Test that `get_sdreport()` returns correct output for the `sdreport` slot. - expect_equal( - object = sdreport, - expected = fit_data@sdreport - ) - - if (any(grepl("fixed_effects", fit_file))) { - #' @description Test that `get_sdreport()` returns correct names for the `sdreport` slot. - expect_equal( - object = names(sdreport), - expected = expected_names - ) - } else { - #' @description Test that `get_sdreport()` returns correct names for the `sdreport` slot. - expect_equal( - object = names(sdreport), - expected = expected_names_re - ) - } - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_sdreport) }) - ## Edge handling ---- test_that("`get_sdreport()` returns correct outputs for edge cases", { #' @description Test that `get_sdreport()` returns an error when given invalid input. diff --git a/tests/testthat/test-get_timing.R b/tests/testthat/test-get_timing.R index f7484cb0c..269931d43 100644 --- a/tests/testthat/test-get_timing.R +++ b/tests/testthat/test-get_timing.R @@ -10,43 +10,43 @@ # get_timing ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big + ## IO correctness ---- test_that("`get_timing()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE - ) - expected_names <- c( "time_optimization", "time_sdreport", "time_total" ) + timing_with_optimization <- get_timing(fit_with_optimization_big) + #' @description Test that `get_timing()` returns correct output for the `timing` slot. + expect_equal( + object = timing_with_optimization, + expected = fit_with_optimization_big@timing + ) + #' @description Test that `get_timing()` returns correct names for the `timing` slot. + expect_equal( + object = names(timing_with_optimization), + expected = expected_names + ) + #' @description Test that `get_timing()` returns > 0 values for the `timing` slot. + expect_true(object = all(timing_with_optimization > 0)) +}) - # Function to read the RDS file and get input - check_timing <- function(fit_file) { - fit_data <- readRDS(fit_file) - timing <- get_timing(fit_data) - #' @description Test that `get_timing()` returns correct output for the `timing` slot. - expect_equal( - object = timing, - expected = fit_data@timing - ) - #' @description Test that `get_timing()` returns correct names for the `timing` slot. - expect_equal( - object = names(timing), - expected = expected_names - ) - #' @description Test that `get_timing()` returns > 0 values for the `timing` slot. - expect_true(object = all(timing > 0)) - } - - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_timing) +test_that("`get_timing()` works with correct inputs without optimization", { + timing_without_optimization <- get_timing(fit_without_optimization_big) + #' @description Test that `get_timing()` returns correct output for the `timing` slot. + expect_equal( + object = timing_without_optimization, + expected = fit_without_optimization_big@timing + ) + #' @description Test that `get_timing()` returns correct names for the `timing` slot. + expect_equal( + object = names(timing_without_optimization), + expected = "time_total" + ) + #' @description Test that `get_timing()` returns 0 seconds for the `timing` slot when optimization is not performed. + expect_true(object = all(timing_without_optimization == 0)) }) ## Edge handling ---- diff --git a/tests/testthat/test-get_version.R b/tests/testthat/test-get_version.R index e3fd0cbb9..56efeed8a 100644 --- a/tests/testthat/test-get_version.R +++ b/tests/testthat/test-get_version.R @@ -10,39 +10,38 @@ # get_version ---- ## Setup ---- # Load or prepare any necessary data for testing -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} -## IO correctness ---- -test_that("`get_version()` works with correct inputs", { - # Load the test data from an RDS file containing model fits. - # List all RDS files in the fixtures directory that match the pattern "fit*_.RDS" - fit_files <- list.files( - path = testthat::test_path("fixtures"), - pattern = "^fit.*\\.RDS$", - full.names = TRUE - ) +fit_with_optimization_big <- FIMS::fit_with_optimization_big +fit_without_optimization_big <- FIMS::fit_without_optimization_big - expected_version <- utils::packageVersion("FIMS") +expected_version <- utils::packageVersion("FIMS") - # Function to read the RDS file and get input - check_version <- function(fit_file) { - fit_data <- readRDS(fit_file) - version <- get_version(fit_data) - #' @description Test that `get_version()` returns correct output for the `version` slot. - expect_equal( - object = version, - expected = fit_data@version - ) - #' @description Test that `get_version()` returns correct version. - expect_equal( - object = version, - expected = expected_version - ) - } +## IO correctness ---- +test_that("`get_version()` works with fit_with_optimization_big", { + version_with_optimization <- get_version(fit_with_optimization_big) + #' @description Test that `get_version()` returns correct output for the `version` slot. + expect_equal( + object = version_with_optimization, + expected = fit_with_optimization_big@version + ) + #' @description Test that `get_version()` returns correct version. + expect_equal( + object = version_with_optimization, + expected = expected_version + ) +}) - # Use purrr::map to apply the function to each file - result <- purrr::map(fit_files, check_version) +test_that("`get_version()` works with fit_without_optimization_big", { + version_without_optimization <- get_version(fit_without_optimization_big) + #' @description Test that `get_version()` returns correct output for the `version` slot. + expect_equal( + object = version_without_optimization, + expected = fit_without_optimization_big@version + ) + #' @description Test that `get_version()` returns correct version. + expect_equal( + object = version_without_optimization, + expected = expected_version + ) }) ## Edge handling ---- diff --git a/tests/testthat/test-integration-caa-mle.R b/tests/testthat/test-integration-caa-mle-without-wrappers.R similarity index 97% rename from tests/testthat/test-integration-caa-mle.R rename to tests/testthat/test-integration-caa-mle-without-wrappers.R index 5a3b63345..b5e21f8f8 100644 --- a/tests/testthat/test-integration-caa-mle.R +++ b/tests/testthat/test-integration-caa-mle-without-wrappers.R @@ -10,6 +10,12 @@ # Deterministic test ---- ## Setup ---- # Load necessary data for the integration test +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { prepare_test_data() } diff --git a/tests/testthat/test-integration-caa-mle-wrappers.R b/tests/testthat/test-integration-caa-mle-wrappers.R index 1d75d848c..713425976 100644 --- a/tests/testthat/test-integration-caa-mle-wrappers.R +++ b/tests/testthat/test-integration-caa-mle-wrappers.R @@ -7,13 +7,9 @@ #' one lines, that will be used in the bookdown report of the results from #' {testthat}. This line can be more than 80 characters. -# Deterministic test ---- +# Model run with age and length comp ---- ## Setup ---- # Load necessary data for the integration test -if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { - prepare_test_data() -} - load(testthat::test_path("fixtures", "integration_test_data.RData")) # Set the iteration ID to 1 for accessing specific input/output list @@ -21,13 +17,13 @@ iter_id <- 1 ## IO correctness ---- test_that("catch-at-age model (deterministic MLE with wrappers) works with correct inputs", { - # Load the test data from an RDS file containing the model fit - deterministic_age_length_comp <- readRDS(testthat::test_path("fixtures", "deterministic_age_length_comp.RDS")) + # Load the test data + deterministic_age_length_comp <- FIMS::fit_without_optimization_big #' @description Test that the output from FIMS deterministic run matches the model comparison project OM values. verify_fims_deterministic( report = get_report(deterministic_age_length_comp), - estimates = get_estimates(deterministic_age_length_comp), + estimates = FIMS::estimates_without_optimization_big, om_input = om_input_list[[iter_id]], om_output = om_output_list[[iter_id]], em_input = em_input_list[[iter_id]], @@ -42,7 +38,7 @@ test_that("catch-at-age model (deterministic MLE with wrappers) works with corre em_input = em_input_list[[iter_id]] ) - parameters <- readRDS(testthat::test_path("fixtures", "parameters_model_comparison_project.RDS")) + parameters <- FIMS::parameters_big number_fixed_effects <- parameters |> dplyr::filter(estimation_type == "fixed_effects") |> dplyr::pull(estimation_type) |> @@ -58,6 +54,31 @@ test_that("catch-at-age model (deterministic MLE with wrappers) works with corre expect_equal(get_number_of_parameters(deterministic_age_length_comp)["random_effects"] |> unname(), number_random_effects) }) +test_that("catch-at-age model (estimation MLE with wrappers) works with age and length comp", { + # Load the test data + fit_age_length_comp <- FIMS::fit_with_optimization_big + + #' @description Test that the output from FIMS matches the model comparison project OM values. + validate_fims( + report = get_report(fit_age_length_comp), + estimates = FIMS::estimates_with_optimization_big, + om_input = om_input_list[[iter_id]], + om_output = om_output_list[[iter_id]], + em_input = em_input_list[[iter_id]], + use_fimsfit = TRUE + ) +}) + +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + +if (!file.exists(testthat::test_path("fixtures", "deterministic_age_length_comp_fixed_effects.RDS"))) { + prepare_test_data() +} + test_that("catch-at-age model (deterministic MLE with wrappers) recruitment devs fixed effects works with correct inputs", { # Load the test data from an RDS file containing the model fit deterministic_age_length_comp <- readRDS(testthat::test_path("fixtures", "deterministic_age_length_comp_fixed_effects.RDS")) @@ -105,21 +126,6 @@ test_that("catch-at-age model (deterministic MLE with wrappers) recruitment devs ## Setup ---- ## IO correctness ---- -test_that("catch-at-age model (estimation MLE with wrappers) works with age and length comp", { - # Load the test data from an RDS file containing the model fit - fit_age_length_comp <- readRDS(testthat::test_path("fixtures", "fit_age_length_comp.RDS")) - - #' @description Test that the output from FIMS matches the model comparison project OM values. - validate_fims( - report = get_report(fit_age_length_comp), - estimates = get_estimates(fit_age_length_comp), - om_input = om_input_list[[iter_id]], - om_output = om_output_list[[iter_id]], - em_input = em_input_list[[iter_id]], - use_fimsfit = TRUE - ) -}) - test_that("catch-at-age model (estimation MLE with wrappers) recruitment devs fixed effects works with age and length comp", { # Load the test data from an RDS file containing the model fit fit_age_length_comp <- readRDS(testthat::test_path("fixtures", "fit_age_length_comp_fixed_effects.RDS")) diff --git a/tests/testthat/test-integration-fims-bayesian-prior-predictive.R b/tests/testthat/test-integration-fims-bayesian-prior-predictive.R index fd7d4e49f..11725e11f 100644 --- a/tests/testthat/test-integration-fims-bayesian-prior-predictive.R +++ b/tests/testthat/test-integration-fims-bayesian-prior-predictive.R @@ -1,3 +1,9 @@ +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + load(testthat::test_path("fixtures", "integration_test_data.RData")) # Set the iteration ID to 1 for accessing specific input/output list diff --git a/tests/testthat/test-integration-fims-estimation-random-effects-with-wrappers.R b/tests/testthat/test-integration-fims-estimation-random-effects-with-wrappers.R index af63cc094..1ef38e44a 100644 --- a/tests/testthat/test-integration-fims-estimation-random-effects-with-wrappers.R +++ b/tests/testthat/test-integration-fims-estimation-random-effects-with-wrappers.R @@ -1,3 +1,9 @@ +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + load(testthat::test_path("fixtures", "integration_test_data.RData")) # Set the iteration ID to 1 for accessing specific input/output list diff --git a/tests/testthat/test-integration-fims-estimation-random-effects-without-wrappers.R b/tests/testthat/test-integration-fims-estimation-random-effects-without-wrappers.R index 63d6595bb..afd2aa900 100644 --- a/tests/testthat/test-integration-fims-estimation-random-effects-without-wrappers.R +++ b/tests/testthat/test-integration-fims-estimation-random-effects-without-wrappers.R @@ -9,6 +9,12 @@ # Deterministic test ---- ## Setup ---- # Load necessary data for the integration test +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + load(testthat::test_path("fixtures", "integration_test_data.RData")) # Set the iteration ID to 1 for accessing specific input/output list diff --git a/tests/testthat/test-integration-fleet-log-obs-error-input.R b/tests/testthat/test-integration-fleet-log-obs-error-input.R index 633f4bc0b..6411e0664 100644 --- a/tests/testthat/test-integration-fleet-log-obs-error-input.R +++ b/tests/testthat/test-integration-fleet-log-obs-error-input.R @@ -7,6 +7,12 @@ #' one lines, that will be used in the bookdown report of the results from #' {testthat}. This line can be more than 80 characters. +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + # Fmort and log_sd dimension check ---- ## setup ---- # Load dataset and set up model for tests diff --git a/tests/testthat/test-integration-proportion-female.R b/tests/testthat/test-integration-proportion-female.R index 195ef24b1..3a8b048d0 100644 --- a/tests/testthat/test-integration-proportion-female.R +++ b/tests/testthat/test-integration-proportion-female.R @@ -8,6 +8,12 @@ #' {testthat}. This line can be more than 80 characters. # integration_proportion_female ---- +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + ## Setup ---- load(test_path("fixtures", "integration_test_data.RData")) diff --git a/tests/testthat/test-projections-looped.R b/tests/testthat/test-projections-looped.R index 3210dc7f7..f493e53ca 100644 --- a/tests/testthat/test-projections-looped.R +++ b/tests/testthat/test-projections-looped.R @@ -1,4 +1,10 @@ ## Setup ---- +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) + # Load necessary data for the integration test if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { prepare_test_data() diff --git a/tests/testthat/test-reshape_json_estimates.R b/tests/testthat/test-reshape_json_estimates.R index 1d8662b1b..3e62cffc5 100644 --- a/tests/testthat/test-reshape_json_estimates.R +++ b/tests/testthat/test-reshape_json_estimates.R @@ -10,6 +10,11 @@ # reshape_json_estimates ---- ## Setup ---- # Load or prepare any necessary data for testing +#' @description Skip the test unless explicitly enabled for heavy integration testing. +testthat::skip_if_not( + testthat:::env_var_is_true("RUN_SLOW_TESTS"), + message = "Skipping: RUN_SLOW_TESTS is not set to true." +) if (!file.exists(testthat::test_path("fixtures", "fit_age_length_comp.RDS"))) { prepare_test_data() } diff --git a/tests/testthat/test-tidy.R b/tests/testthat/test-tidy.R index dd4f79b80..86880386e 100644 --- a/tests/testthat/test-tidy.R +++ b/tests/testthat/test-tidy.R @@ -10,18 +10,17 @@ # tidy ---- ## Setup ---- -fit <- local({ - clear() - withr::defer(clear(), envir = parent.env(environment())) - data("data_big", package = "FIMS") - data_4_model <- FIMSFrame(data_big) - create_default_parameters( - configurations = create_default_configurations(data = data_4_model), - data = data_4_model - ) |> - initialize_fims(data = data_4_model) |> - fit_fims(optimize = TRUE) -}) +fit <- FIMS::fit_with_optimization_big +estimates_with_optimization_big <- FIMS::estimates_with_optimization_big +# generics::tidy() expects an object of class FIMSFit and internally calls +# get_estimates(). The saved fit object is a FIMSFit object but missing covariance +# matrix (to reduce file size) and get_estimates() will error. Here we mock +# get_estimates() to return the saved estimates_with_optimization_big object so +# that generics::tidy() can run. +testthat::local_mocked_bindings( + get_estimates = function(x) estimates_with_optimization_big, + .env = asNamespace("FIMS") +) ## IO correctness ---- test_that("tidy() works with correct inputs", { diff --git a/vignettes/fims-demo.Rmd b/vignettes/fims-demo.Rmd index c1f6844ee..6982552bf 100644 --- a/vignettes/fims-demo.Rmd +++ b/vignettes/fims-demo.Rmd @@ -278,7 +278,7 @@ The list returned from `initialize_fims()` can be passed to the parameter of `fi ### Example -```{r fit, max.height='100px', attr.output='.numberLines', eval=TRUE} +```{r fit, max.height='100px', attr.output='.numberLines', eval=FALSE} # Run the model without optimization to help ensure a viable model test_fit <- parameters_4_model |> initialize_fims(data = data_4_model) |> @@ -290,11 +290,19 @@ fit <- parameters_4_model |> fit_fims(optimize = TRUE) ``` +```{r load-precomputed-fit, echo=FALSE} +# Load the pre-computed objects saved in package data +data("fit_without_optimization_big", "fit_with_optimization_big", package = "FIMS") + +test_fit <- fit_without_optimization_big +fit <- fit_with_optimization_big +``` + ### Logging system You can look at the log file in R or write it to the disk but you must run `get_log()` before you run clear to obtain information about the model because clear removes everything from memory, including the log. `get_log()` returns the log information as a string. This string can be manipulated into a data frame using `jsonlite::fromJSON()`. There are three logging levels, "info", "warning", and "error". The log below will not have any error messages but if you were to have error messages and you want to know immediately upon the first error that there are problems, you can run `set_log_throw_on_error(TRUE)` prior to running your model. See the vignette on [FIMS logging](fims-logging.html) or the [doxygen documentation](https://noaa-fims.github.io/FIMS/doxygen/classfims_1_1FIMSLog.html) for more information. -```{r example-log, eval = TRUE} +```{r example-log, eval = FALSE} log_json_string <- get_log() log_data_frame <- jsonlite::fromJSON(log_json_string) log_data_frame[1, ] @@ -309,7 +317,7 @@ clear() The results can be plotted with either base R, {ggplot2}, or {stockplotr}. Where, we recommend using {stockplotr} where possible. -```{r fit-output} +```{r fit-output, eval = FALSE} # Temporary manipulation to the returned estimates to get them # to work with stockplotr output <- get_estimates(fit) |> @@ -320,6 +328,18 @@ output <- get_estimates(fit) |> ) ``` +```{r load-precomputed-estimates, echo=FALSE} +# Load the pre-computed objects saved in package data +data("estimates_with_optimization_big", package = "FIMS") + +output <- estimates_with_optimization_big |> + dplyr::mutate( + uncertainty_label = "se", + year = year_i, + estimate = estimated + ) +``` + ```{r fit-plot-spawning-biomass} #| warning: false #| message: false