diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 0725e6b94..39191dc22 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -13,7 +13,7 @@ "packages": "make,gcc,g++,cmake,clang-tidy,clang-format,clang,doxygen,ninja-build,libxtst6,libxt6" }, "ghcr.io/rocker-org/devcontainer-features/r-packages:1": { - "packages": "RcppEigen,dplyr,ggplot2,jsonlite,magrittr,methods,Rcpp,scales,TMB,usethis,devtools", + "packages": "RcppEigen,dplyr,ggplot2,jsonlite,magrittr,methods,Rcpp,scales,TMB,usethis,devtools,tibble", "installSystemRequirements": true }, // option to run rstudio. you can type rserver into the command line to diff --git a/.github/workflows/build-deploy-doxygen.yml b/.github/workflows/build-deploy-doxygen.yml index 564419150..09c640169 100644 --- a/.github/workflows/build-deploy-doxygen.yml +++ b/.github/workflows/build-deploy-doxygen.yml @@ -19,7 +19,7 @@ jobs: steps: - name: Get repository - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Installing build dependencies run: | diff --git a/.github/workflows/build-doxygen.yml b/.github/workflows/build-doxygen.yml index f65a51d3d..ed0913636 100644 --- a/.github/workflows/build-doxygen.yml +++ b/.github/workflows/build-doxygen.yml @@ -21,7 +21,7 @@ jobs: steps: - name: Get repository - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: Installing build dependencies run: | diff --git a/.github/workflows/call-allcontributors.yml b/.github/workflows/call-allcontributors.yml new file mode 100644 index 000000000..55252a872 --- /dev/null +++ b/.github/workflows/call-allcontributors.yml @@ -0,0 +1,38 @@ +name: Collect contributors + +on: + workflow_dispatch: + schedule: + - cron: '0 8 * * 1' + +jobs: + run-r-script: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + pull-requests: write + steps: + - name: Checkout repository + uses: actions/checkout@v3 + - name: Setup R + uses: r-lib/actions/setup-r@v2 + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + packages: | + gh + allcontributors + - name: Collect contributor data + run: Rscript -e 'allcontributors::add_contributors(files = c("README.md"), alphabetical = FALSE)' + - name: Create Pull Request + uses: peter-evans/create-pull-request@v5 + with: + commit-message: "Update contributors" + branch: update-contributors + title: "Update contributors" + body: "This PR updates the contributors list." + labels: "auto-update" + add-paths: | + README.md diff --git a/.github/workflows/call-spell-check.yml b/.github/workflows/call-spell-check.yml new file mode 100644 index 000000000..0e6d4d36e --- /dev/null +++ b/.github/workflows/call-spell-check.yml @@ -0,0 +1,17 @@ +# run devtools::spell_check() +name: call-spell-check +# on specifies the build triggers. See more info at https://docs.github.com/en/actions/learn-github-actions/events-that-trigger-workflows +on: +# this workflow runs on pushing to main, pull requests to main, and manually. + push: + branches: + - main + - dev + pull_request: + branches: + - main + - dev + workflow_dispatch: +jobs: + call-workflow: + uses: nmfs-fish-tools/ghactions4r/.github/workflows/spell-check.yml@main diff --git a/.github/workflows/get-gtest-codecov.yml b/.github/workflows/get-gtest-codecov.yml index 191e99641..473e08a86 100644 --- a/.github/workflows/get-gtest-codecov.yml +++ b/.github/workflows/get-gtest-codecov.yml @@ -26,7 +26,7 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Install Ninja run: sudo apt-get install ninja-build - uses: r-lib/actions/setup-r@v2 diff --git a/.github/workflows/pr-checklist.yml b/.github/workflows/pr-checklist.yml index 6f258dfdd..d37dd7311 100644 --- a/.github/workflows/pr-checklist.yml +++ b/.github/workflows/pr-checklist.yml @@ -10,7 +10,7 @@ jobs: name: pr-checklist steps: - name: Checkout - uses: actions/checkout@v3 + uses: actions/checkout@v4 - name: 'Comment PR' uses: actions/github-script@0.3.0 if: github.event_name == 'pull_request' diff --git a/.github/workflows/run-clang-format.yml b/.github/workflows/run-clang-format.yml index 9fa64b658..966e5d57d 100644 --- a/.github/workflows/run-clang-format.yml +++ b/.github/workflows/run-clang-format.yml @@ -23,7 +23,7 @@ jobs: # Format hpp and cpp files under inst/include, src/, and test/gtest # We use Google style to format code. steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: DoozyX/clang-format-lint-action@v0.14 with: source: './inst/include ./src ./tests/gtest' diff --git a/.github/workflows/run-clang-tidy.yml b/.github/workflows/run-clang-tidy.yml index de72920e4..083512181 100644 --- a/.github/workflows/run-clang-tidy.yml +++ b/.github/workflows/run-clang-tidy.yml @@ -19,7 +19,7 @@ jobs: strategy: fail-fast: false steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: install clang-tidy run: sudo apt update && sudo apt -y install clang-tidy diff --git a/.github/workflows/run-googletest.yml b/.github/workflows/run-googletest.yml index 97897b1f0..67da5a4fe 100644 --- a/.github/workflows/run-googletest.yml +++ b/.github/workflows/run-googletest.yml @@ -19,7 +19,7 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Install Ninja shell: bash run: ${{ runner.os == 'macOS' && 'brew install ninja' || runner.os == 'Windows' && 'choco install ninja' || 'sudo apt-get install ninja-build' }} diff --git a/.gitignore b/.gitignore index 1f4b5aa51..af204bef9 100644 --- a/.gitignore +++ b/.gitignore @@ -21,11 +21,6 @@ # RStudio files .Rproj.user/ -# produced vignettes and libraries -vignettes/*.html -vignettes/*.pdf -vignettes/*/libs/ - # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 .httr-oauth @@ -85,12 +80,14 @@ vignettes/*/libs/ # IDE specific files *.vscode +**/.vscode/ # mac OS files *.DS_Store -# All log file +# All log files and json output *.log +*.json #TMB tmp.def file src/tmp.def diff --git a/CMakeLists.txt b/CMakeLists.txt index 64d98dd30..008dea9ed 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -7,7 +7,7 @@ project(FIMS ) # CXX is the language name # GoogleTest requires at least C++11 -set(CMAKE_CXX_STANDARD 11) +set(CMAKE_CXX_STANDARD 17) include(FetchContent) diff --git a/DESCRIPTION b/DESCRIPTION index da3442970..acd1eab18 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,45 +1,123 @@ Package: FIMS Title: The Fisheries Integrated Modeling System -Version: 0.2.0.0 +Version: 0.3.0.0 Authors@R: c( - person("Christine", "Stawitz", , "christine.stawitz@noaa.gov", role = c("aut", "cre"), - comment = c(ORCID = "0000-0003-3122-4501")), - person("Nathan", "Vaughan", role = "aut"), - person("Howard", "Townsend", role = "aut"), - person(c("Ian", "G."), "Taylor", role = "aut", - comment = c(ORCID = "0000-0002-4232-5669")), - person("Matthew", "Supernaw", role = "aut"), - person("Jane", "Sullivan", role = "aut"), - person("Kyle", "Shertzer", role = "aut", - comment = c(ORCID = "0000-0001-7196-5959")), - person("Megumi", "Oshima", role = "aut"), - person(c("Cole", "C."), "Monnahan", role = "aut", - comment = c(ORCID = "0000-0003-0871-6700")), - person(c("Timothy", "J."), "Miller", role = "aut", - comment = c(ORCID = "0000-0003-1411-1206")), - person("Richard", "Methot", role = "aut"), - person("Patrick", "Lynch", role = "aut", - comment = c(ORCID = "0000-0001-7121-6181")), - person("Bai", "Li", role = "aut", - comment = c(ORCID = "0000-0002-8249-1442")), - person("Huihua", "Lee", role = "aut"), - person(c("Christopher", "M."), "Legault", role = "aut", - comment = c(ORCID = "0000-0002-0328-1376")), - person(c("Kelli", "F."), "Johnson", role = "aut", - comment = c(ORCID = "0000-0002-5149-451X")), - person(c("James", "N."), "Ianelli", role = "aut", - comment = c(ORCID = "0000-0002-7170-8677")), - person("Alan", "Haynie", role = "aut"), - person(c("Andrea", "M."), "Havron", role = "aut", - comment = c(ORCID = "0000-0002-4080-448X")), - person(c("Kathryn", "L."), "Doering", role = "aut", - comment = c(ORCID = "0000-0002-0396-7044")), - person(c("Edward", "J."), "Dick", role = "aut", - comment = c(ORCID = "0000-0001-7681-9176")), - person("Jon", "Brodziak", role = "aut"), - person("Kristan", "Blackhart", role = "aut"), - person("Peter", "Kuriyama", role = "aut", - comment = c(ORCID = "0000-0002-6971-4015")) + person( + role = c("aut", "cre"), + family = "Johnson", + given = c("Kelli", "F."), + email = "kelli.johnson@noaa.gov", + comment = c(ORCID = "0000-0002-5149-451X") + ), + person( + role = "aut", + family = "Brodziak", + given = c("Jon", "K.", "T."), + comment = c(ORCID = "0000-0001-8690-5588") + ), + person( + role = "aut", + family = "Doering", + given = c("Kathryn", "L."), + comment = c(ORCID = "0000-0002-0396-7044") + ), + person( + role = "aut", + family = "Havron", + given = c("Andrea", "M."), + comment = c(ORCID = "0000-0002-4080-448X") + ), + person( + role = "aut", + family = "Klasky", + given = c("Ronald"), + comment = c(ORCID = "0009-0004-7563-7716") + ), + person( + role = "aut", + family = "Kuriyama", + given = c("Peter", "T."), + comment = c(ORCID = "0000-0002-6971-4015") + ), + person( + role = "aut", + family = "Legault", + given = c("Christopher", "M."), + comment = c(ORCID = "0000-0002-0328-1376") + ), + person( + role = "aut", + family = "Li", + given = "Bai", + comment = c(ORCID = "0000-0002-8249-1442") + ), + person( + role = "aut", + family = "Miller", + given = c("Timothy", "J."), + comment = c(ORCID = "0000-0003-1411-1206") + ), + person( + role = "aut", + family = "Monnahan", + given = c("Cole", "C."), + comment = c(ORCID = "0000-0003-0871-6700") + ), + person( + role = "aut", + family = "Oshima", + given = c("Megumi", "C."), + comment = c(ORCID = "0009-0002-2239-1594") + ), + person( + role = "aut", + family = "Shertzer", + given = c("Kyle", "W."), + comment = c(ORCID = "0000-0001-7196-5959") + ), + person( + role = "aut", + family = "Stawitz", + given = c("Christine", "C."), + email = "christine.stawitz@noaa.gov", + comment = c(ORCID = "0000-0003-3122-4501") + ), + person( + role = "aut", + family = "Sullivan", + given = c("Jane", "Y."), + comment = c(ORCID = "0000-0002-8094-1673") + ), + person( + role = "aut", + family = "Supernaw", + given = "Matthew", + comment = c(ORCID = "0009-0007-3681-7433") + ), + person( + role = "aut", + family = "Taylor", + given = c("Ian", "G."), + comment = c(ORCID = "0000-0002-4232-5669") + ), + person( + role = "aut", + family = "Vaughan", + given = c("Nathan", "R."), + comment = c(ORCID = "0009-0000-3054-6950") + ), + person( + role = "ctb", + family = "Blackhart", + given = "Kristan", + comment = c(ORCID = "0000-0003-4232-2510") + ), + person( + role = "ctb", + family = "Ianelli", + given = c("James", "N."), + comment = c(ORCID = "0000-0002-7170-8677") + ) ) Description: The Fisheries Integrated Modeling System is a next-generation framework of stock assessment models, assisting fishery managers with @@ -54,31 +132,39 @@ License: GPL (>= 3) | file LICENSE URL: https://github.com/noaa-fims/fims, https://noaa-fims.github.io BugReports: https://github.com/noaa-fims/fims/issues Depends: - R (>= 4.0) -Imports: + R (>= 4.1.0) +Imports: + cli, dplyr, ggplot2, + glue, jsonlite, methods, + purrr, Rcpp, + rlang, scales, - TMB (>= 1.8.0) -Suggests: + stats, + tibble, + TMB (>= 1.8.0), + utils +Suggests: covr, knitr, + mockery, parallel, remotes, rmarkdown, snowfall, testthat (>= 3.0.0), - tidyverse, + tidyr, usethis, withr -LinkingTo: +LinkingTo: Rcpp, RcppEigen, TMB -VignetteBuilder: +VignetteBuilder: knitr Config/testthat/edition: 3 Config/testthat/parallel: true diff --git a/NAMESPACE b/NAMESPACE index 0f2f4b377..06b25aeca 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,34 +3,79 @@ export(AgeComp) export(BevertonHoltRecruitment) export(CreateTMBModel) +export(DlnormDistribution) +export(DmultinomDistribution) +export(DnormDistribution) export(DoubleLogisticSelectivity) export(EWAAgrowth) +export(FIMSFit) export(FIMSFrame) export(Fleet) export(Index) +export(LengthComp) export(LogisticMaturity) export(LogisticSelectivity) export(Parameter) +export(ParameterVector) export(Population) -export(TMBDlnormDistribution) -export(TMBDmultinomDistribution) -export(TMBDnormDistribution) export(clear) -export(clear_logs) +export(create_default_parameters) +export(finalize) +export(fit_fims) +export(get_ages) +export(get_data) +export(get_end_year) +export(get_estimates) export(get_fixed) +export(get_fleets) +export(get_input) +export(get_lengths) +export(get_log) +export(get_log_errors) +export(get_log_module) +export(get_log_warnings) +export(get_max_gradient) +export(get_n_ages) +export(get_n_lengths) +export(get_n_years) +export(get_number_of_parameters) +export(get_obj) +export(get_opt) +export(get_output) export(get_random) +export(get_report) +export(get_sdreport) +export(get_start_year) +export(get_timing) +export(get_version) +export(initialize_data_distribution) +export(initialize_fims) +export(initialize_process_distribution) +export(is.FIMSFit) +export(is.FIMSFits) +export(log_error) +export(log_info) +export(log_warning) +export(lognormal) +export(m_age_to_length_conversion) export(m_agecomp) export(m_index) export(m_landings) +export(m_lengthcomp) +export(m_weight_at_age) +export(multinomial) export(run_gtest) +export(set_log_throw_on_error) export(setup_and_run_gtest) export(setup_gtest) -exportMethods(m_agecomp) -exportMethods(m_index) -exportMethods(m_landings) +export(update_parameters) +exportMethods(Math) +exportMethods(Ops) +exportMethods(Summary) import(methods) import(stats) importFrom(Rcpp,sourceCpp) importFrom(TMB,MakeADFun) importFrom(ggplot2,.data) +importFrom(rlang,":=") useDynLib(FIMS, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 4594a0e92..598c23aef 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,29 @@ +# FIMS 0.3.0.0 + +* Fits to length data using an age-to-length-conversion matrix, `data1` + includes the necessary information needed to fit to both ages and lengths. +* Adds C++ ParameterVector to allow for the estimation of time-varying + parameters. +* Implements R wrapper functions to facilitate + * creating the input model specifications with `create_default_*()`, + `update_parameters()`, and `initialize_*()`; + * adding -999 to the missing fleet, year, age, length, etc. combinations; + * running the model with a user-supplied argument of n_of_loops, where the + default is three, to restart the optimizer from the previous run of nlmimb; + * summarizing the output with the `FIMSFit()` function and class. +* Implements a switch for global verbosity within FIMS through the use + of {cli} messages and warnings. +* Updates the logging system complete with a vignette about how to use it, the + logging system can be used for both R and C++ errors, warnings, and + information. +* Creates the initial infrastructure to implement random effects with density + functions. +* Implements a helper function to get the parameter names from the + C++ code and populate the results with those names. +* Makes lpdf_vec return 0 if data is missing. + # FIMS 0.2.0.0 + * Added a `pkgdown` site for FIMS * Add code cov tests and site link * Remove recruitment bias correction and adjustment because we plan to use `TMB` (https://github.com/NOAA-FIMS/FIMS/issues/185) @@ -13,7 +38,6 @@ * Refactor vectors to use `fims::Vector` class * Add Newton steps to FIMS integration test to improve convergence in integration test - # FIMS 0.1.0.0 * Added a `NEWS.md` file to track changes to the package. diff --git a/R/FIMS-package.R b/R/FIMS-package.R index cd2c913d9..675c5d9e0 100644 --- a/R/FIMS-package.R +++ b/R/FIMS-package.R @@ -1,27 +1,39 @@ ## usethis namespace: start -#' @useDynLib FIMS, .registration = TRUE -#' @importFrom Rcpp sourceCpp -#' @importFrom TMB MakeADFun -#' @import stats -#' @import methods -#' @importFrom ggplot2 .data +#' @export AgeComp +#' @export BevertonHoltRecruitment +#' @export clear #' @export CreateTMBModel +#' @export DlnormDistribution +#' @export DmultinomDistribution +#' @export DnormDistribution +#' @export DoubleLogisticSelectivity +#' @export EWAAgrowth +#' @export finalize +#' @export Fleet #' @export get_fixed +#' @export get_log +#' @export get_log_errors +#' @export get_log_module +#' @export get_log_warnings +#' @export get_output #' @export get_random -#' @export clear -#' @export clear_logs -#' @export Parameter -#' @export BevertonHoltRecruitment -#' @export Fleet -#' @export AgeComp #' @export Index -#' @export Population -#' @export TMBDnormDistribution +#' @export LengthComp +#' @export log_error +#' @export log_info +#' @export log_warning #' @export LogisticMaturity #' @export LogisticSelectivity -#' @export DoubleLogisticSelectivity -#' @export EWAAgrowth -#' @export TMBDlnormDistribution -#' @export TMBDmultinomDistribution +#' @export Parameter +#' @export ParameterVector +#' @export Population +#' @export set_log_throw_on_error +#' @import methods +#' @import stats +#' @importFrom ggplot2 .data +#' @importFrom Rcpp sourceCpp +#' @importFrom rlang := +#' @importFrom TMB MakeADFun +#' @useDynLib FIMS, .registration = TRUE ## usethis namespace: end NULL diff --git a/R/create_default_parameters.R b/R/create_default_parameters.R new file mode 100644 index 000000000..3ac5a059a --- /dev/null +++ b/R/create_default_parameters.R @@ -0,0 +1,718 @@ +# TODO: Document the names/items in each list that are returned +#' Create default parameters for a FIMS model +#' +#' @description +#' This function generates default parameter settings for a Fisheries +#' Integrated Modeling System (FIMS) model, including recruitment, growth, +#' maturity, population, and fleet configurations. It applies default +#' configurations when specific module settings are not provided by the user. +#' @param data An S4 object. FIMS input data. +#' @param fleets A named list of settings for the fleet module. Each element of +#' the list should specify a fleet's selectivity form and settings for the +#' data distribution. If this argument is missing, default values will be +#' applied for each fleet that is not specified but present in `data` based +#' on the types of information present for that fleet. +#' @param recruitment A list specifying the settings for the recruitment +#' module. The default is a Beverton--Holt recruitment relationship with +#' log-normal recruitment deviations. +#' @param growth A list specifying the settings for the growth module. The +#' default is `"EWAAgrowth"`. +#' @param maturity A list specifying the settings for the maturity module. The +#' default is `"LogisticMaturity"`. +#' @return +#' A list containing the following two entries: +#' \describe{ +#' \item{\code{parameters}:}{A list of parameter inputs for the FIMS +#' model.} +#' \item{\code{modules}:}{A list of modules with default or user-provided +#' settings.} +#' } +#' @export +#' @seealso +#' * [update_parameters()] +#' @examples +#' \dontrun{ +#' data("data1") +#' fims_frame <- FIMSFrame(data1) +#' fleet1 <- survey1 <- list( +#' selectivity = list(form = "LogisticSelectivity"), +#' data_distribution = c( +#' Index = "DlnormDistribution", +#' AgeComp = "DmultinomDistribution" +#' ) +#' ) +#' fleet2 <- list( +#' selectivity = list(form = "DoubleLogisticSelectivity"), +#' data_distribution = c( +#' Index = "DlnormDistribution", +#' AgeComp = "DmultinomDistribution", +#' LengthComp = "DmultinomDistribution" +#' ) +#' ) +#' default_parameters <- fims_frame |> +#' create_default_parameters( +#' fleets = list(fleet1 = fleet1, fleet2 = fleet2, survey1 = survey1), +#' recruitment = list( +#' form = "BevertonHoltRecruitment", +#' process_distribution = c(log_devs = "DnormDistribution") +#' ), +#' growth = list(form = "EWAAgrowth"), +#' maturity = list(form = "LogisticMaturity") +#' ) +#' } +create_default_parameters <- function( + data, + fleets, + recruitment = list( + form = "BevertonHoltRecruitment", + process_distribution = c(log_devs = "DnormDistribution") + ), + # TODO: Rename EWAAgrowth to not use an acronym + growth = list(form = "EWAAgrowth"), + maturity = list(form = "LogisticMaturity") +) { + # FIXME: use default values if there are no fleets info passed into the + # function or a fleet is not present but it has data? Maybe we don't want the + # latter because it could be that we want to drop a fleet from a model but we + # don't want to alter the data? + + # Check for fleet names that do not match those in the data object + fleet_names <- names(fleets) + mismatch_fleet_names <- fleet_names[ + !(fleet_names %in% unique(dplyr::pull(get_data(data), name))) + ] + if (length(mismatch_fleet_names) > 0) { + cli::cli_abort(c( + "i" = "The name of the fleets for selectivity settings must match + the fleet names present in the {.var data}.", + "x" = "The following {length(mismatch_fleet_names)} fleet name{?s} + {?is/are} missing from the data: {mismatch_fleet_names}." + )) + } + + # Create module list + module_list <- list( + fleets = fleets, + recruitment = recruitment, + growth = growth, + maturity = maturity + ) + + # Create fleet parameters + fleet_temp <- list() + for (i in 1:length(fleets)) { + fleet_temp <- c( + fleet_temp, + create_default_fleet( + fleets = fleets, + fleet_name = names(fleets)[i], + data = data + ) + ) + } + + # Create recruitment parameters + recruitment_temp <- create_default_recruitment( + recruitment = recruitment, + data = data, + input_type = recruitment[["form"]] + ) + + # Create maturity parameters + maturity_temp <- create_default_maturity(form = maturity$form) + + # Create population parameters + # Handle population parameters based on recruitment form + if (recruitment[["form"]] == "BevertonHoltRecruitment") { + log_rzero <- recruitment_temp[["recruitment"]][[ + paste0(recruitment[["form"]], ".log_rzero.value") + ]] + } + population_temp <- create_default_Population(data, log_rzero) + + # Compile output + output <- list( + parameters = c( + fleet_temp, + recruitment_temp, + maturity_temp, + population_temp + ), + modules = module_list + ) + return(output) +} + +#' Create default population parameters +#' +#' @description +#' This function sets up default parameters for a population module. +#' @details +#' The natural log of the initial numbers at age (`log_init_naa.value`) is set based on +#' unexploited recruitment and natural mortality. +#' @param data An S4 object. FIMS input data. +#' @param log_rzero A numeric value representing the natural log of unexploited +#' recruitment. +#' @return +#' A named list of default population parameters, including initial numbers at +#' age and natural mortality rate. +#' @noRd +create_default_Population <- function(data, log_rzero) { + # Input checks + # Check if log_rzero is numeric + if (!is.numeric(log_rzero) || length(log_rzero) != 1) { + local_bullets <- c( + "i" = "{.var log_rzero} argument must be a single numeric value.", + "x" = "{.var log_rzero} has a length of {length(log_rzero)}.", + "x" = "{.var log_rzero} is of the class {class(log_rzero)}." + ) + names(local_bullets)[2] <- ifelse(length(log_rzero) > 1, "x", "i") + names(local_bullets)[3] <- ifelse(inherits(log_rzero, "numeric"), "i", "x") + cli::cli_abort(local_bullets) + } + + # Extract necessary values from data + n_years <- get_n_years(data) + n_ages <- get_n_ages(data) + + # Set natural mortality rate + M_value <- 0.2 + + # Calculate initial numbers at age based on log_rzero and M_value + init_naa <- exp(log_rzero) * exp(-(get_ages(data) - 1) * M_value) + init_naa[n_ages] <- init_naa[n_ages] / M_value # sum of infinite series + + # Create a list of default parameters + default <- list( + log_M.value = rep(log(M_value), n_years * n_ages), + log_M.estimated = FALSE, + log_init_naa.value = log(init_naa), + log_init_naa.estimated = TRUE + ) + + # Name the list elements + names(default) <- paste0("Population.", names(default)) + # Wrap the default parameters in a population list for output + population_list <- list(default) + names(population_list) <- "population" + return(population_list) +} + +#' Create default logistic parameters +#' +#' @description +#' This function sets up default parameters for a logistic function. There are +#' two specified parameters, the inflection point and slope. +#' @return +#' A list containing the default logistic parameters, with inflection_point and +#' slope values and their estimation status. +#' @noRd +create_default_Logistic <- function() { + default <- list( + inflection_point.value = 2, + inflection_point.estimated = TRUE, + slope.value = 1, + slope.estimated = TRUE + ) + return(default) +} + +#' Create default double logistic parameters +#' +#' @description +#' This function sets up default parameters for a double logistic function. +#' There four specified parameters, two for the ascending and two for the +#' descending inflection points and slopes. +#' @return +#' A list containing the default double logistic parameters, +#' inflection_point_asc, slope_asc, inflection_point_desc, and slope_desc +#' values and their estimation status. +#' @noRd +create_default_DoubleLogistic <- function() { + logistic_defaults <- create_default_Logistic() + default <- structure( + rep(logistic_defaults, 2), + names = c( + gsub("\\.", "_asc.", names(logistic_defaults)), + gsub("\\.", "_desc.", names(logistic_defaults)) + ) + ) + # TODO: Determine if this should really be 4? + default[["inflection_point_desc.value"]] <- 4 + + return(default) +} + +#' Create default selectivity parameters +#' +#' @description +#' This function sets up default parameters for a selectivity module. +#' @param form A string specifying the desired form of selectivity. Allowable +#' forms include `r toString(formals(create_default_selectivity)[["form"]])` +#' and the default is +#' `r toString(formals(create_default_selectivity)[["form"]][1])`. +#' @return +#' A list is returned with the default parameter values for the specified form +#' of selectivity. +#' @noRd +create_default_selectivity <- function( + form = c("LogisticSelectivity", "DoubleLogisticSelectivity") +) { + # Input checks + form <- rlang::arg_match(form) + # NOTE: All new forms of selectivity must be placed in the vector of default + # arguments for `form` and their methods but be placed below in the call to + # `switch` + default <- switch(form, + "LogisticSelectivity" = create_default_Logistic(), + "DoubleLogisticSelectivity" = create_default_DoubleLogistic() + ) + names(default) <- paste0(form, ".", names(default)) + + return(default) +} + +#' Create default fleet parameters +#' +#' @description +#' This function sets up default parameters for a fleet module. It compiles +#' selectivity parameters along with distributions for each type of data that +#' are present for the given fleet. +#' +#' @param fleets A list of fleet configurations. +#' @param fleet_name A character. Name of the fleet. +#' @param data An S4 object. FIMS input data. +#' @return +#' A list with default parameters for the fleet. +#' @noRd +create_default_fleet <- function(fleets, + fleet_name, + data) { + # Input checks + if (length(fleet_name) > 1) { + cli::cli_abort(c( + "i" = "{.var fleet_name} should have a length of 1.", + "x" = "{.var fleet_name} has a length of {length(fleet_name)}." + )) + } + if (!inherits(fleet_name, "character")) { + cli::cli_abort(c( + "i" = "{.var fleet_name} should be a string.", + "x" = "{.var fleet_name} is a {class(fleet_name)}." + )) + } + if (!fleet_name %in% names(fleets)) { + cli::cli_abort(c( + "i" = "{.var fleet_name} should be present in the names of {.var fleets}.", + "x" = "{.var {fleet_name}} is not in {names(fleets)}." + )) + } + + # Create default selectivity parameters + selectivity_default <- create_default_selectivity( + form = fleets[[fleet_name]][["selectivity"]][["form"]] + ) + + # Get types of data for this fleet from the data object + data_types_present <- get_data(data) |> + dplyr::filter(name == fleet_name) |> + dplyr::pull(type) |> + unique() + + # Determine default fleet parameters based on types of data present + # FIXME: allow for a fleet to have both landings and index data + process_default <- if ("landings" %in% data_types_present) { + list( + log_Fmort.value = log(rep(0.00001, get_n_years(data))), + log_Fmort.estimated = TRUE + ) + } else { + list( + log_q.value = 0, + log_q.estimated = TRUE + ) + } + + names(process_default) <- paste0("Fleet.", names(process_default)) + + # Create index distribution defaults + index_distribution <- fleets[[fleet_name]][["data_distribution"]]["Index"] + + # FIXME: Will this work if both landings and index data are present? + index_uncertainty <- get_data(data) |> + dplyr::filter(name == fleet_name, type %in% c("landings", "index")) |> + dplyr::arrange(dplyr::desc(type)) |> + dplyr::pull(uncertainty) + + index_distribution_default <- switch( + index_distribution, + "DnormDistribution" = create_default_DnormDistribution( + value = index_uncertainty, + input_type = "data", + data = data + ), + "DlnormDistribution" = create_default_DlnormDistribution( + value = index_uncertainty, + input_type = "data", + data = data + ) + ) + names(index_distribution_default) <- paste0( + index_distribution, + ".", + names(index_distribution_default) + ) + + # Compile all default parameters into a single list + default <- list(c( + selectivity_default, + process_default, + index_distribution_default) + ) + + names(default) <- fleet_name + return(default) +} + +#' Create default maturity parameters +#' +#' @description +#' This function sets up default parameters for a maturity module. +#' @param form A string specifying the form of maturity (e.g., +#' `"LogisticMaturity"`). +#' @return +#' A list containing the default maturity parameters. +#' @noRd +create_default_maturity <- function(form = c("LogisticMaturity")) { + # Input checks + form <- rlang::arg_match(form) + + # NOTE: All new forms of maturity must be placed in the vector of default + # arguments for `form` and their methods but be placed below in the call to + # `switch` + default <- list( + "maturity" = switch(form, + "LogisticMaturity" = create_default_Logistic() + ) + ) + names(default[["maturity"]]) <- paste0(form, ".", names(default[["maturity"]])) + + return(default) +} + +#' Create default Beverton--Holt recruitment parameters +#' +#' @description +#' This function sets up default parameters for a Beverton--Holt recruitment +#' relationship. Parameters include the natural log of unfished recruitment, +#' the logit transformation of the slope of the spawner-–recruitment curve to +#' keep it between zero and one, and the time series of spawner-recruitment +#' deviations on the natural log scale. +#' @param data An S4 object. FIMS input data. +#' @return +#' A list containing default recruitment parameters. +#' @noRd +create_default_BevertonHoltRecruitment <- function(data) { + # Create default parameters for Beverton--Holt recruitment + default <- list( + log_rzero.value = log(1e+06), + log_rzero.estimated = TRUE, + logit_steep.value = -log(1.0 - 0.75) + log(0.75 - 0.2), + logit_steep.estimated = FALSE, + log_devs.value = rep(0.0, get_n_years(data) - 1), + log_devs.estimated = TRUE, + estimate_log_devs = TRUE + ) + return(default) +} + +#' Create default DnormDistribution parameters +#' +#' @description +#' This function sets up default parameters to calculate the density of a +#' normal distribution, i.e., `DnormDistribution`, module. +#' @param value A real number that is passed to `log_sd`. The default value is +#' `0.1`. +#' @param data An S4 object. FIMS input data. +#' @param input_type A string specifying the input type. The available options +#' are +#' `r toString(formals(create_default_DnormDistribution)[["input_type"]])`. +#' The default is +#' `r toString(formals(create_default_DnormDistribution)[["input_type"]][1])`. +#' @return +#' A list of default parameters for DnormDistribution. +#' @noRd +create_default_DnormDistribution <- function( + value = 0.1, + data, + input_type = c("data", "process") +) { + # Input checks + input_type <- rlang::arg_match(input_type) + + # Create default parameters + default <- list( + log_sd.value = value, + log_sd.estimated = FALSE + ) + + # If input_type is 'process', add additional parameters + if (input_type == "process") { + default <- c( + default, + list( + x.value = rep(0, get_n_years(data)), + x.estimated = FALSE, + expected_values.value = rep(0, get_n_years(data)), + expected_values.estimated = FALSE + ) + ) + } + return(default) +} + +#' Create default DlnormDistribution parameters +#' +#' @description +#' This function sets up default parameters to calculate the density of a +#' log-normal distribution, i.e., `DlnormDistribution`, module. +#' @param value Default value for `log_sd`. +#' @param data An S4 object. FIMS input data. +#' @param input_type A string specifying the input type. The available options +#' are +#' `r toString(formals(create_default_DlnormDistribution)[["input_type"]])`. +#' The default is +#' `r toString(formals(create_default_DlnormDistribution)[["input_type"]][1])`. +#' @return +#' A list of default parameters for DlnormDistribution. +#' @noRd +create_default_DlnormDistribution <- function( + value = 0.1, + data, + input_type = c("data", "process") +) { + # Input checks + # TODO: Determine if value can be a vector? + if (!is.numeric(value) || any(value <= 0, na.rm = TRUE)) { + cli::cli_abort(c( + "i" = "Inputs to {.var value} must be positive and numeric.", + "x" = "{.var value} is {.var {value}}." + )) + } + input_type <- rlang::arg_match(input_type) + + # Create the default list with log standard deviation + default <- list( + log_sd.value = log(value), + log_sd.estimated = FALSE + ) + + # Add additional parameters if input_type is "process" + if (input_type == "process") { + default <- c( + default, + list( + x.value = rep(0, get_n_years(data)), + x.estimated = FALSE, + expected_values.value = rep(0, get_n_years(data)), + expected_values.estimated = FALSE + ) + ) + } + return(default) +} + +#' Create default recruitment parameters +#'#' +#' @description +#' This function sets up default parameters for a recruitment module. +#' +#' @param recruitment A list with recruitment details, including form and +#' process distribution type. +#' @param data An S4 object. FIMS input data. +#' @param input_type A string specifying the type of recruitment you want to +#' use. The available options are +#' `r toString(formals(create_default_recruitment)[["input_type"]])`. The +#' default is +#' `r toString(formals(create_default_recruitment)[["input_type"]][1])`. +#' @return +#' A list with the default parameters for recruitment. +#' @noRd +create_default_recruitment <- function( + recruitment, + data, + input_type = "BevertonHoltRecruitment") { + # Input checks + if (!is.list(recruitment)) { + cli::cli_abort(c( + "i" = "The {.var recruitment} argument must be a list.", + "x" = "{.var recruitment} is a {class(recruitment)}." + )) + } + form <- rlang::arg_match(input_type) + # Create default parameters based on the recruitment form + # NOTE: All new forms of recruitment must be placed in the vector of default + # arguments for `form` and their methods but be placed below in the call to + # `switch` + process_default <- switch( + form, + "BevertonHoltRecruitment" = create_default_BevertonHoltRecruitment(data) + ) + names(process_default) <- paste0(form, ".", names(process_default)) + + # Create default distribution parameters based on the distribution type + distribution_input <- recruitment[["process_distribution"]] + distribution_default <- NULL + if (!is.null(distribution_input)) { + distribution_default <- switch( + distribution_input, + "DnormDistribution" = create_default_DnormDistribution( + data = data, + input_type = "process" + ) + ) + names(distribution_default) <- paste0( + distribution_input, + ".", + names(distribution_default) + ) + } + + # Combine process and distribution defaults into a single list + default <- list(c(process_default, distribution_default)) + names(default) <- "recruitment" + return(default) +} + +#' Update input parameters for a FIMS model +#' +#' @description +#' This function updates the input parameters of a Fisheries Integrated +#' Modeling System (FIMS) model. It allows users to modify specific parameters +#' by providing new values, while retaining the existing modules information +#' from the current input. +#' @param current_parameters A list containing the current input parameters, including: +#' \describe{ +#' \item{\code{parameters}:}{A list of parameter inputs.} +#' \item{\code{modules}:}{A list of module names used in the model.} +#' } +#' @param modified_parameters A named list representing new parameter values to update. +#' @rdname create_default_parameters +#' @return +#' A list containing: +#' \describe{ +#' \item{parameters}{A list of updated parameter inputs that +#' includes any modifications made by the user.} +#' \item{modules}{The unchanged list of module names from the current +#' input.} +#' } +#' @seealso +#' * [create_default_parameters()] +#' @export +update_parameters <- function(current_parameters, modified_parameters) { + # Input checks + # Check if current_parameters is a list with required components + if ( + !is.list(current_parameters) || + !all(c("parameters", "modules") %in% names(current_parameters)) + ) { + cli::cli_abort(c( + "i" = "{.var current_parameters} argument must be a list containing + parameters and modules.", + "x" = "{.var current_parameters} is a {class(current_parameters)}." + )) + } + # Check if modified_parameters is a named list + if (!is.list(modified_parameters) || is.null(names(modified_parameters))) { + cli::cli_abort(c( + "i" = "{.var modified_parameters} argument must be must be a named list.", + "x" = "{.var modified_parameters} is a {class(modified_parameters)}." + )) + } + + # Check if modified_parameters exists in current_parameters + missing_input <- setdiff( + names(modified_parameters), + names(current_parameters[["parameters"]]) + ) + if (length(missing_input) > 0) { + cli::cli_abort(c( + "x" = "The following {length(missing_input)} input list{?s} from + {.var modified_parameters} {?is/are} missing from + {.var current_parameters}: {missing_input}." + )) + } + + wrong_input <- setdiff( + names(current_parameters[["parameters"]]), + names(modified_parameters) + ) + if (length(missing_input) > 0) { + cli::cli_abort(c( + "x" = "The following {length(missing_input)} input list{?s} from + {.var modified_parameters} {?is/are} missing from + {.var current_parameters}: {missing_input}." + )) + } + + new_param_input <- current_parameters[["parameters"]] + module_names <- names(new_param_input) + + # Update parameters for each module based on modified_parameters + for (module_name in module_names) { + if (module_name %in% names(modified_parameters)) { + modified_params <- modified_parameters[[module_name]] + current_params <- new_param_input[[module_name]] + + for (param_name in names(modified_params)) { + # Check if the parameter exists in current_parameters + if (!param_name %in% names(current_params)) { + cli::cli_abort(c( + "x" = "{param_name} from {module_name} in {.var modified_parameters} + does not exist in {.var current_parameters}." + )) + } + + # Check if the length of the modified and current parameter match + length_modified_parameter <- length(modified_params[[param_name]]) + length_current_parameter <- length(current_params[[param_name]]) + if (!identical(length_modified_parameter, length_current_parameter)) { + cli::cli_abort(c( + "x" = "The length of {.var {param_name}} from {module_name} + does not match between {.var modified_parameters} and + {.var current_parameters}.", + "i" = "The parameter name of interest is {.var {param_name}}.", + "i" = "The length of the modified parameter is + {length_modified_parameter}.", + "i" = "The length of the current parameter is + {length_current_parameter}." + )) + } + + # Check if the type of the modified and current parameter match + if (!identical( + typeof(modified_params[[param_name]]), + typeof(current_params[[param_name]]) + )) { + cli::cli_abort(c( + "x" = "The type of {param_name} from {module_name} does not match + between {.var modified_parameters} and + {.var current_parameters}." + )) + } + + # Update the parameter if checks pass + current_params[[param_name]] <- modified_params[[param_name]] + } + + # Assign the updated module parameters back to new_param_input + new_param_input[[module_name]] <- current_params + } + } + # Create a new list for updated input + new_input <- list( + parameters = new_param_input, + modules = current_parameters$modules + ) + return(new_input) +} diff --git a/R/data_mile1.R b/R/data1.R similarity index 76% rename from R/data_mile1.R rename to R/data1.R index a986d7604..c63bc2849 100644 --- a/R/data_mile1.R +++ b/R/data1.R @@ -1,19 +1,22 @@ -#' FIMS input data frame for milestone 1 +#' FIMS input data frame #' #' A dataset containing information necessary to run an age-structured stock -#' assessment model in FIMS for milestone 1. This data was generated using +#' assessment model in FIMS. This data was generated using #' the `ASSAMC` package written for the [model comparison project]( #' www.github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison). #' -#' @format A data frame with `r NROW(data_mile1)` observations of -#' `r NCOL(data_mile1)` variables: -#' \describe{ -#' \item{type}{The type of data the row contains. Allowed types include -#' `age`, `index`, `landings`, and `weight-at-age` data.} +#' @format +#' A data frame with `r NROW(data1)` observations of `r NCOL(data1)` +#' variables: +#' \describe{ \item{type}{The type of data the row contains. Allowed types +#' include `age`, `length`, `index`, `landings`, `age-to-length-conversion`, +#' and `weight-at-age` data.} #' \item{name}{A character string providing the name of the information source -#' that the data was collected from, e.g., `"Trawl fishery"`} +#' that the data was collected from, e.g., `"Trawl fishery"`.} #' \item{age}{An integer age. Entry can be `NA` if information pertains to #' multiple ages, e.g., total catch rather than catch of age-4 fish.} +#' \item{length}{A numeric length. Entry can be `NA` if information doesn't +#' pertain to length.} #' \item{datestart,dateend}{Start and end dates of the data collection period. #' Format all dates using `yyyy-mm-dd`, which can accommodate fake years #' such as `0001-01-01`.} @@ -31,4 +34,4 @@ #' } #' } #' @source \url{www.github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison} -"data_mile1" +"data1" diff --git a/R/distribution_formulas.R b/R/distribution_formulas.R new file mode 100644 index 000000000..f94ecb1df --- /dev/null +++ b/R/distribution_formulas.R @@ -0,0 +1,473 @@ +#' Validity checks for distributions +#' +#' This function checks the validity of arguments passed to functions that +#' relate to distributions within the Fisheries Integrated Modeling System +#' (FIMS). This function is designed to fail early only once, otherwise it goes +#' through many checks before reporting the results in an attempt to give the +#' user the most information possible. If it were to fail on every mistake, +#' then the user might have to iterate through multiple changes to their input +#' values. Sometimes, their mistakes might take quite a bit of time to make it +#' to this function or worse they might be running things on the cloud and not +#' have immediate access to the report. Therefore, we feel that providing the +#' most information possible is the best way forward. +#' +#' @param args A named list of input arguments that must contain at least +#' `family` and `sd`. `data_type` is only needed for some upstream functions. +#' @seealso +#' This function is used in the following functions: +#' * [initialize_data_distribution()] +#' * [initialize_process_distribution()] +#' @noRd +#' @return +#' If successful, `TRUE` is invisibly returned. If unsuccessful, +#' [cli::cli_abort()] is used to return the relevant error messages. +check_distribution_validity <- function(args) { + # Separate objects from args + family <- args[["family"]] + sd <- args[["sd"]] + # Optional argument data_type + data_type <- args[["data_type"]] + check_present <- purrr::map_vec(list("family" = family, "sd" = sd), is.null) + + # Set up global rules + # FIXME: Move this to a data item in the package so it can be used everywhere + # Could do a call to all data objects in the package and get unique types that + # are available + data_type_names <- c("index", "agecomp", "lengthcomp") + if (is.null(data_type)) { + available_distributions <- c("lognormal", "gaussian") + } else { + available_distributions <- switch( + EXPR = ifelse(grepl("comp", data_type), "composition", data_type), + "index" = c("lognormal", "gaussian"), + "composition" = c("multinomial"), + "unavailable data type" + ) + } + elements_of_sd <- c("value", "estimated") + + # Start a bulleted list of errors and add to it in each if statement + abort_bullets <- c( + " " = "The following errors were found in the input argument {.var args}." + ) + if (any(check_present)) { + bad <- names(check_present[unlist(check_present)]) + abort_bullets <- c( + abort_bullets, + "x" = "{.var {bad}} {?is/are} missing from {.var args}." + ) + # Abort early because not all of the necessary items were in args + cli::cli_abort(abort_bullets) + } + + # Checks related to the family class + if (!inherits(family, "family")) { + abort_bullets <- c( + abort_bullets, + "x" = "The class of {.var family} is incorrect.", + "i" = "{.var family} should be an object of class {.var family}, + e.g., `family = gaussian()`, instead of {class(family)}." + ) + } + if ( + !(family[["family"]] %in% available_distributions) || + "unavailable data type" %in% available_distributions + ) { + ifelse_type <- ifelse( + is.null(data_type), + "distribution", + paste(data_type, "data") + ) + abort_bullets <- c( + abort_bullets, + "x" = "FIMS currently does not allow the family to be + {.code {family[['family']]}}.", + "i" = "The families available for this {ifelse_type} are + {.code {available_distributions}}." + ) + } + + # Checks related to the type of data + if (!is.null(data_type)) { + if (!(data_type %in% data_type_names)) { + abort_bullets <- c( + abort_bullets, + "x" = "The specified {.var data_type} of {.var {data_type}} is not + available.", + "i" = "Allowed values for {.var data_type} are + {.code {data_type_names}}." + ) + } + } + + # Checks related to standard deviation + # Check if sd has both elements and if yes, then go onto the else statement + # for major checks + if (!all(elements_of_sd %in% names(sd))) { + abort_bullets <- c( + abort_bullets, + "x" = "{.var {elements_of_sd}} need to be present in sd.", + "i" = "Only {.code {names(sd)}} {?is/are} present." + ) + } else { + if (!all(sd[["value"]] > 0)) { + abort_bullets <- c( + abort_bullets, + "x" = "Values passed to {.var sd} are out of bounds.", + "i" = "Values passed to {.var sd} {?is/are} {.code {sd[['value']]}}.", + "i" = "All standard deviation (sd) values need to be positive." + ) + } + if ( + length(sd[["estimated"]]) > 1 && + length(sd[["value"]]) != length(sd[["estimated"]]) + ) { + sd_length <- length(sd[["value"]]) + est_length <- length(sd[["estimated"]]) + abort_bullets <- c( + abort_bullets, + "x" = "The sizes of {.var value} and {.var estimated} within {.var sd} + must match if more than one value is specified for the latter.", + "i" = "The length of {.var sd[['value']]} is {.code {sd_length}}.", + "i" = "The length of {.var sd[['estimated']]} is + {.code {est_length}}." + ) + } + } + + # Return error messages if more than just the default is present + if (length(abort_bullets) == 1) { + invisible(TRUE) + } else { + cli::cli_abort(abort_bullets) + } +} + +#' Return name of expected value +#' +#' The combination of data type, family, and link lead to a specific name for +#' the expected value within the code base. This function looks at the +#' combination of these three objects and specifies the appropriate string for +#' its name going forward. +#' @inheritParams initialize_data_distribution +#' @noRd +#' @return +#' A string specifying the name of the expected value. +#' +get_expected_name <- function(family, data_type) { + # TODO: Think about if the name of the expected value should change based on + # the link or if it should stay the same? Keeping track of different names in + # the code base might be too complex for the output as well + family_string <- family[["family"]] + link_string <- family[["link"]] + expected_name <- dplyr::case_when( + data_type == "index" && + grepl("lognormal|gaussian", family_string) && + link_string == "log" ~ "log_expected_index", + data_type == "index" && + grepl("lognormal|gaussian", family_string) && + link_string == "identity" ~ "expected_index", + grepl("agecomp", data_type) ~ "proportion_catch_numbers_at_age", + grepl("lengthcomp", data_type) ~ "proportion_catch_numbers_at_length", + ) + # Check combination of entries was okay and led to valid name + if (is.na(expected_name)) { + cli::cli_abort(c( + "x" = "The combination of data type, family, and link are incompatible in + some way.", + "i" = "{.var data_type} is {.var {data_type}}.", + "i" = "The family is {.var {family_string}}.", + "i" = "The link is {.var {link_string}}." + )) + } + return(expected_name) +} + +#' Set up a new distribution for a data type or a process +#' +#' Use [methods::new()] to set up a distribution within an existing module with +#' the necessary linkages between the two. For example, a fleet module will need +#' a distributional assumption for parts of the data associated with it, which +#' requires the use of `initialize_data_distribution()`, and a recruitment +#' module, like the Beverton--Holt stock--recruit relationship, will need a +#' distribution associated with the recruitment deviations, which requires +#' `initialize_process_distribution()`. +#' @param module An identifier to a C++ fleet module that is linked to the data +#' of interest. +#' @param family A description of the error distribution and link function to +#' be used in the model. The argument takes a family class, e.g., +#' `stats::gaussian(link = "identity")`. +#' @param sd A list of length two. The first entry is named `"value"` and it +#' stores the initial values (scalar or vector) for the relevant standard +#' deviations. The default is `value = 1`. The second entry is named +#' `"estimated"` and it stores a vector of booleans (default = FALSE) is a +#' scalar indicating whether or not standard deviation is estimated. If +#' `"value"` is a vector and `"estimated"` is a scalar, the single value +#' specified `"estimated"` value will be repeated to match the length of +#' `value`. Otherwise, the dimensions of the two must match. +#' @param data_type A string specifying the type of data that the +#' distribution will be fit to. Allowable types include +#' `r toString(formals(initialize_data_distribution)[["data_type"]])` +#' and the default is +#' `r toString(formals(initialize_data_distribution)[["data_type"]][1])`. +#' @param par A string specifying the parameter name the distribution applies +#' to. Parameters must be members of the specified module. Use +#' `methods::show(module)` to obtain names of parameters within the module. +#' @param is_random_effect A boolean indicating whether or not the process is +#' estimated as a random effect. +#' @return +#' A reference class. is returned. Use [methods::show()] to view the various +#' Rcpp class fields, methods, and documentation. +#' @keywords distribution +#' @export +#' @examples +#' \dontrun{ +#' # Set up a new data distribution +#' n_years <- 30 +#' # Create a new fleet module +#' fleet <- methods::new(Fleet) +#' # Create a distribution for the fleet module +#' fleet_distribution <- initialize_data_distribution( +#' module = fishing_fleet, +#' family = lognormal(link = "log"), +#' sd = list( +#' value = rep(sqrt(log(0.01^2 + 1)), n_years), +#' estimated = rep(FALSE, n_years) # Could also be a single FALSE +#' ), +#' data_type = "index" +#' ) +#' +#' # Set up a new process distribution +#' # Create a new recruitment module +#' recruitment <- methods::new(BevertonHoltRecruitment) +#' # view parameter names of the recruitment module +#' methods::show(BevertonHoltRecruitment) +#' # Create a distribution for the recruitment module +#' recruitment_distribution <- initialize_process_distribution( +#' module = recruitment, +#' par = "log_devs", +#' family = gaussian(), +#' sd = list(value = 0.4, estimated = FALSE), +#' is_random_effect = FALSE +#' ) +#' } +initialize_data_distribution <- function( + module, + family, + sd = list(value = 1, estimated = FALSE), + # FIXME: Move this argument to second to match where par is in + # initialize_process_distribution + data_type = c("index", "agecomp", "lengthcomp") +) { + data_type <- rlang::arg_match(data_type) + # FIXME: Make the available families a data object + # Could also make the matrix of distributions available per type as a + # data frame where the check could use the stored object. + + + # validity check on user input + args <- list( + family = family, + sd = sd, + data_type = data_type + ) + check_distribution_validity(args) + + # assign name of observed data based on data_type + obs_id_name <- glue::glue("observed_{data_type}_data_id") + + # Set up distribution based on `family` argument` + if (family[["family"]] == "lognormal") { + # create new Rcpp module + new_module <- methods::new(DlnormDistribution) + + # populate logged standard deviation parameter with log of input + new_module$log_sd <- methods::new( + ParameterVector, + log(sd[["value"]]), + length(sd[["value"]]) + ) + # setup whether or not sd parameter is estimated + if (length(sd[["value"]]) > 1 && length(sd[["estimated"]]) == 1) { + new_module$log_sd$set_all_estimable(sd[["estimated"]]) + } else { + for (i in 1:seq_along(sd[["estimated"]])) { + new_module$log_sd[i]$estimated <- sd[["estimated"]][i] + } + } + } + + if (family[["family"]] == "gaussian") { + # create new Rcpp module + new_module <- methods::new(DnormDistribution) + + # populate logged standard deviation parameter with log of input + new_module$log_sd$resize(length(sd[["value"]])) + for (i in seq_along(sd[["value"]])){ + new_module$log_sd[i]$value <- log(sd[["value"]][i]) + } + + # setup whether or not sd parameter is estimated + if (length(sd[["value"]]) > 1 && length(sd[["estimated"]]) == 1) { + new_module$log_sd$set_all_estimable(sd[["estimated"]]) + } else { + for (i in 1:seq_along(sd[["estimated"]])) { + new_module$log_sd[i]$estimated <- sd[["estimated"]][i] + } + } + } + + if (family[["family"]] == "multinomial") { + #create new Rcpp module + new_module <- methods::new(DmultinomDistribution) + } + + # setup link to observed data + if (data_type == "index") { + new_module$set_observed_data(module$GetObservedIndexDataID()) + } + if (data_type == "agecomp") { + new_module$set_observed_data(module$GetObservedAgeCompDataID()) + } + if (data_type == "lengthcomp") { + new_module$set_observed_data(module$GetObservedLengthCompDataID()) + } + + # set name of expected values + expected <- get_expected_name(family, data_type) + # setup link to expected values + new_module$set_distribution_links("data", module$field(expected)$get_id()) + + return(new_module) +} + +#' @rdname initialize_data_distribution +#' @keywords distribution +#' @export +initialize_process_distribution <- function( + module, + par, + family, + sd = list(value = 1, estimated = FALSE), + is_random_effect = FALSE +) { + # validity check on user input + args <- list(family = family, sd = sd) + check_distribution_validity(args) + + # Set up distribution based on `family` argument` + if (family[["family"]] == "lognormal") { + # create new Rcpp module + new_module <- methods::new(DlnormDistribution) + + # populate logged standard deviation parameter with log of input + new_module$log_sd <- methods::new( + ParameterVector, + log(sd[["value"]]), + length(sd[["value"]]) + ) + #setup whether or not sd parameter is estimated + if (length(sd[["value"]]) > 1 && length(sd[["estimated"]]) == 1) { + new_module$log_sd$set_all_estimable(sd[["estimated"]]) + } else { + for (i in 1:seq_along(sd[["estimated"]])) { + new_module$log_sd[i]$estimated <- sd[["estimated"]][i] + } + } + } + + if (family[["family"]] == "gaussian") { + # create new Rcpp module + new_module <- methods::new(DnormDistribution) + + # populate logged standard deviation parameter with log of input + new_module$log_sd$resize(length(sd[["value"]])) + for (i in seq_along(sd[["value"]])){ + new_module$log_sd[i]$value <- log(sd[["value"]][i]) + } + + #setup whether or not sd parameter is estimated + if (length(sd[["value"]]) > 1 && length(sd[["estimated"]]) == 1) { + new_module$log_sd$set_all_estimable(sd[["estimated"]]) + } else { + for (i in 1:seq_along(sd[["estimated"]])) { + new_module$log_sd[i]$estimated <- sd[["estimated"]][i] + } + } + } + + # indicate whether or not parameter is treated as a random effect in the model + module$field(par)$set_all_random(is_random_effect) + + n_dim <- length(module$field(par)) + + # create new Rcpp modules + new_module$x$resize(n_dim) + new_module$expected_values$resize(n_dim) + + # initialize values with 0 + # these are overwritten in the code later by user input + for (i in 1:n_dim) { + new_module$x[i]$value <- 0 + new_module$expected_values[i]$value <- 0 + } + + # setup links to parameter + new_module$set_distribution_links( + "random_effects", + module$field(par)$get_id() + ) + + return(new_module) +} + +#' Distributions not available in the stats package +#' +#' Family objects provide a convenient way to specify the details of the models +#' used by functions such as [stats::glm()]. These functions within this +#' package are not available within the stats package but are designed in a +#' similar manner. +#' +#' @param link A string specifying the model link function. For example, +#' `"identity"` or `"log"` are appropriate names for the [stats::gaussian()] +#' distribution. `"log"` and `"logit"` are the defaults for the lognormal and +#' the multinomial, respectively. +#' @return +#' An object of class `family` (which has a concise print method). This +#' particular family has a truncated length compared to other distributions in +#' [stats::family()]. +#' \item{family}{character: the family name.} +#' \item{link}{character: the link name.} +#' +#' @seealso +#' * [stats::family()] +#' * [stats::gaussian()] +#' * [stats::glm()] +#' * [stats::power()] +#' * [stats::make.link()] +#' @keywords distribution +#' @export +#' @examples +#' a_family <- multinomial() +#' a_family[["family"]] +#' a_family[["link"]] +lognormal <- function(link = "log") { + family_class <- c( + list(family = "lognormal", link = link), + stats::make.link(link) + ) + class(family_class) <- "family" + return(family_class) +} + +#' @rdname lognormal +#' @keywords distribution +#' @export +multinomial <- function(link = "logit") { + family_class <- c( + list(family = "multinomial", link = link), + stats::make.link(link) + ) + class(family_class) <- "family" + return(family_class) +} diff --git a/R/fimsfit.R b/R/fimsfit.R new file mode 100644 index 000000000..47cbaed7d --- /dev/null +++ b/R/fimsfit.R @@ -0,0 +1,588 @@ +# Developers: ---- + +# This file defines the parent class of FIMSFit and its potential children. The +# class is an S4 class with accessors and validators but no setters. For more +# details on how to create an S4 class in FIMS please see R/fimsframe.R + +# TODO: ---- + +# TODO: Fix "no metadata object found to revise superClass" in sdreportOrList +# TODO: Write more validity checks for FIMSFit +# TODO: Better document the return of [get_estimates()], i.e., columns +# TODO: Decide if the error from is.FIMSFits should be a single FALSE or stop +# TODO: Decide if "total" should be a part of number_of_parameters because it +# can be calculated from fixed_effects + random_effects and would need to +# be calculated in print.FITFims() +# TODO: Determine if report should always use last.par.best +# TODO: Make a helper function to add lower and upper CI for users in estimates +# TODO: Add Terminal SB to print() + +# methods::setClass: ---- + +# Need to use an S3 class for the following S4 class +methods::setOldClass(Classes = "package_version") +methods::setOldClass(Classes = "difftime") +methods::setOldClass(Classes = "sdreport") +# Join sdreport and list into a class incase the sdreport is not created +methods::setClassUnion("sdreportOrList", members = c("sdreport", "list")) + +methods::setClass( + Class = "FIMSFit", + slots = c( + input = "list", + obj = "list", + opt = "list", + max_gradient = "numeric", + report = "list", + sdreport = "sdreportOrList", + estimates = "tbl_df", + number_of_parameters = "integer", + timing = "difftime", + version = "package_version" + ) +) + +methods::setMethod( + f = "print", + signature = "FIMSFit", + definition = function(x) { + rt <- as.numeric(x@timing[["time_total"]], units = "secs") + ru <- "seconds" + if (rt > 60 * 60 * 24) { + rt <- rt / (60 * 60 * 24) + ru <- "days" + } else if (rt > 60 * 60) { + rt <- rt / (60 * 60) + ru <- "hours" + } else if (rt > 60) { + rt <- rt / 60 + ru <- "minutes" + } + + number_of_parameters <- paste( + names(x@number_of_parameters), + x@number_of_parameters, + sep = "=" + ) + div_digit <- cli::cli_div(theme = list(.val = list(digits = 5))) + terminal_ssb <- sapply( + x@report[["ssb"]], + function(y) utils::tail(y, 1) + ) + cli::cli_inform(c( + "i" = "FIMS model version: {.val {x@version}}", + "i" = "Total run time was {.val {rt}} {ru}", + "i" = "Number of parameters: {number_of_parameters}", + "i" = "Maximum gradient= {.val {x@max_gradient}}", + "i" = "Negative log likelihood (NLL):", + "*" = "Marginal NLL= {.val {x@opt$objective}}", + "*" = "Total NLL= {.val {x@report$jnll}}", + # TODO: x@rep[["sb"]] does not exist + "i" = "Terminal SB= " + )) + cli::cli_end(div_digit) + } +) + +# methods::setMethod: accessors ---- + +# Accessor functions for a FIMSFit object +# 1 setGeneric() per slot but potentially >1 setMethod() per setGeneric() + +#' Get a slot in a FIMSFit object +#' +#' There is an accessor function for each slot in the S4 class `FIMSFit`, where +#' the function is named `get_*()` and the star can be replaced with the slot +#' name, e.g., [get_input()]. These accessor functions are the preferred way +#' to access objects stored in the available slots. +#' +#' @param x Output returned from [fit_fims()]. +#' @name get_FIMSFit +#' @seealso +#' * [fit_fims()] +#' * [create_default_parameters()] +NULL + +#' @return +#' [get_input()] returns the list that was used to fit the FIMS model, which +#' is the returned object from [create_default_parameters()]. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +methods::setGeneric("get_input", function(x) standardGeneric("get_input")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +methods::setMethod("get_input", "FIMSFit", function(x) x@input) + +#' @return +#' [get_report()] returns the TMB report, where anything that is flagged as +#' reportable in the C++ code is returned. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_report", function(x) standardGeneric("get_report")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_report", "FIMSFit", function(x) x@report) + +#' @return +#' [get_obj()] returns the output from [TMB::MakeADFun()]. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_obj", function(x) standardGeneric("get_obj")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_obj", "FIMSFit", function(x) x@obj) + +#' @return +#' [get_opt()] returns the output from [nlminb()], which is the minimizer used +#' in [fit_fims()]. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_opt", function(x) standardGeneric("get_opt")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_opt", "FIMSFit", function(x) x@opt) + +#' @return +#' [get_max_gradient()] returns the maximum gradient found when optimizing the +#' model. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_max_gradient", function(x) standardGeneric("get_max_gradient")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_max_gradient", "FIMSFit", function(x) x@max_gradient) + + +#' @return +#' [get_sdreport()] returns the list from [TMB::sdreport()]. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_sdreport", function(x) standardGeneric("get_sdreport")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_sdreport", "FIMSFit", function(x) x@sdreport) + +#' @return +#' [get_estimates()] returns a tibble of parameter values and their +#' uncertainties from a fitted model. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_estimates", function(x) standardGeneric("get_estimates")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_estimates", "FIMSFit", function(x) x@estimates) + +#' @return +#' [get_number_of_parameters()] returns a vector of integers specifying the +#' number of fixed-effect parameters and the number of random-effect parameters +#' in the model. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric( + "get_number_of_parameters", + function(x) standardGeneric("get_number_of_parameters") +) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod( + "get_number_of_parameters", + "FIMSFit", + function(x) x@get_number_of_parameters +) + +#' @return +#' [get_timing()] returns the amount of time it took to run the model in +#' seconds as a `difftime` object. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_timing", function(x) standardGeneric("get_timing")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_timing", "FIMSFit", function(x) x@timing) + +#' @return +#' [get_version()] returns the `package_version` of FIMS that was used to fit +#' the model. +#' @export +#' @rdname get_FIMSFit +#' @keywords fit_fims +setGeneric("get_version", function(x) standardGeneric("get_version")) +#' @rdname get_FIMSFit +#' @keywords fit_fims +setMethod("get_version", "FIMSFit", function(x) x@version) + +# methods::setValidity ---- + +methods::setValidity( + Class = "FIMSFit", + method = function(object) { + errors <- character() + + # Check that obj is from TMB::MakeADFun() + TMB_MakeADFun_names <- c( + "par", "fn", "gr", "he", "hessian", "method", "retape", "env", "report", + "simulate" + ) + if (!setequal(names(object@obj), TMB_MakeADFun_names)) { + errors <- c( + errors, + "obj must be a list returned from TMB::MakeADFun() but it does not + appear to be so because it does not have the standard names." + ) + } + + # Return + if (length(errors) == 0) { + return(TRUE) + } else { + return(errors) + } + } +) + +# methods::setMethod: is.FIMSFit ---- + +#' Check if an object is of class FIMSFit +#' +#' @param x Returned list from [fit_fims()]. +#' @keywords fit_fims +#' @export +is.FIMSFit <- function(x) { + inherits(x, "FIMSFit") +} + +#' Check if an object is a list of FIMSFit objects +#' +#' @param x List of fits returned from multiple calls to [fit_fims()]. +#' @keywords fit_fims +#' @export +is.FIMSFits <- function(x) { + if (!is.list(x)) { + cli::cli_warn( + message = c("x" = "{.par x} is not a list -- something went wrong.") + ) + return(FALSE) + } + all(sapply(x, function(i) inherits(i, "FIMSFit"))) +} + +# Constructors ---- + +#' Class constructors for class `FIMSFit` and associated child classes +#' +#' Create an object with the class of `FIMSFit` after running a FIMS model. This +#' is typically done within [fit_fims()] but it can be create manually by the +#' user if they have used their own bespoke code to fit a FIMS model. +#' +#' @inheritParams fit_fims +#' @param obj An object returned from [TMB::MakeADFun()]. +#' @param opt An object returned from an optimizer, typically from +#' [stats::nlminb()], used to fit a TMB model. +#' @param sdreport An object of the `sdreport` class as returned from +#' [TMB::sdreport()]. +#' @param timing A vector of at least length one, where all entries are of the +#' `timediff` class and at least one is named "time_total". This information +#' is available in [fit_fims()] and added to this argument internally but if +#' you are a power user you can calculate the time it took to run your model +#' by subtracting two [Sys.time()] objects. +#' @param version The version of FIMS that was used to optimize the model. If +#' [fit_fims()] was not used to optimize the model, then the default is to +#' use the current version of the package that is loaded. +#' +#' @return +#' An object with an S4 class of `FIMSFit` is returned. The object will have the +#' following slots: +#' \describe{ +#' \item{\code{input}:}{ +#' A list containing the model setup in the same form it was passed. +#' } +#' \item{\code{obj}:}{ +#' A list returned from [TMB::MakeADFun()] in the same form it was passed. +#' } +#' \item{\code{opt}:}{ +#' A list containing the optimized model in the same form it was passed. +#' } +#' \item{\code{max_gradient}:}{ +#' The maximum gradient found when optimizing the model. The default is +#' `NA`, which means that the model was not optimized. +#' } +#' \item{\code{report}:}{ +#' A list containing the model report from `obj[["report"]]()`. +#' } +#' \item{\code{sdreport}:}{ +#' A object with the `sdreport` class containing the output from +#' `TMB::sdreport(obj)`. +#' } +#' \item{\code{estimates}:}{ +#' A table of parameter values and their uncertainty. +#' } +#' \item{\code{timing}:}{ +#' The length of time it took to run the model if it was optimized. +#' } +#' \item{\code{version}:}{ +#' The package version of FIMS used to fit the model or at least the +#' version used to create this output, which will not always be the same +#' if you are running this function yourself. +#' } +#' } +#' @keywords fit_fims +#' @export +FIMSFit <- function( + input, + obj, + opt = list(), + sdreport = list(), + timing = c("time_total" = as.difftime(0, units = "secs")), + version = utils::packageVersion("FIMS") +) { + # What we aspire the estimate table to look like + estimates_outline <- dplyr::tibble( + label = character(), + fleet = character(), + age = numeric(), + time = numeric(), + initial = numeric(), + estimate = numeric(), + uncertainty = numeric(), + likelihood = numeric(), + gradient = numeric(), + estimated = logical() + ) + rm(estimates_outline) + + # Determine the number of parameters + n_total <- length(obj[["env"]][["last.par.best"]]) + n_fixed_effects <- length(obj[["par"]]) + number_of_parameters <- c( + total = n_total, + fixed_effects = n_fixed_effects, + random_effects = n_total - n_fixed_effects + ) + rm(n_total, n_fixed_effects) + + # Calculate the maximum gradient + max_gradient <- if (length(opt) > 0) { + max(abs(obj[["gr"]](opt[["par"]]))) + } else { + NA_real_ + } + + # Rename parameters instead of "p" + parameter_names <- names(get_parameter_names(obj[["par"]])) + names(obj[["par"]]) <- parameter_names + + # Get the report + report <- if (length(opt) == 0) { + obj[["report"]](obj[["env"]][["last.par.best"]]) + } else { + obj[["report"]]() + } + + if (length(sdreport) > 0) { + names(sdreport[["par.fixed"]]) <- parameter_names + dimnames(sdreport[["cov.fixed"]]) <- list(parameter_names, parameter_names) + std <- summary(sdreport) + estimates <- tibble::tibble( + as.data.frame(std) + ) |> + dplyr::rename(value = "Estimate", se = "Std. Error") |> + dplyr::mutate( + name = dimnames(std)[[1]], + .before = "value" + ) + } else { + estimates <- tibble::tibble( + name = names(obj[["par"]]), + value = obj[["env"]][["parList"]]()[["p"]], + se = NA_real_ + ) + } + + fit <- methods::new( + "FIMSFit", + input = input, + obj = obj, + opt = opt, + max_gradient = max_gradient, + report = report, + sdreport = sdreport, + estimates = estimates, + number_of_parameters = number_of_parameters, + timing = timing, + version = version + ) + fit +} + +#' Fit a FIMS model (BETA) +#' +#' @param input Input list as returned by [initialize_fims()]. +#' @param get_sd A boolean specifying if the [TMB::sdreport()] should be +#' calculated? +#' @param save_sd A logical, with the default `TRUE`, indicating whether the +#' sdreport is returned in the output. If `FALSE`, the slot for the report +#' will be empty. +#' @param number_of_loops A positive integer specifying the number of +#' iterations of the optimizer that will be performed to improve the +#' gradient. The default is three, leading to four total optimization steps. +#' @param optimize Optimize (TRUE, default) or (FALSE) build and return +#' a list containing the obj and report slot. +#' @param number_of_newton_steps The number of Newton steps using the inverse +#' Hessian to do after optimization. Not yet implemented. +#' @param control A list of optimizer settings passed to [stats::nlminb()]. The +#' the default is a list of length three with `eval.max = 1000`, +#' `iter.max = 10000`, and `trace = 0`. +#' @param filename Character string giving a file name to save the fitted +#' object as an RDS object. Defaults to 'fit.RDS', and a value of NULL +#' indicates not to save it. If specified, it must end in .RDS. The file is +#' written to folder given by `input[["path"]]`. Not yet implemented. +#' @return +#' An object of class `FIMSFit` is returned, 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`. +#' @seealso +#' * [FIMSFit()] +#' @details This function is a beta version still and subject to change +#' without warning. +#' @keywords fit_fims +#' @export +fit_fims <- function(input, + get_sd = TRUE, + save_sd = TRUE, + number_of_loops = 3, + optimize = TRUE, + number_of_newton_steps = 0, + control = list( + eval.max = 10000, + iter.max = 10000, + trace = 0 + ), + filename = NULL) { + if (!is.null(input$random)) { + cli::cli_abort("Random effects declared but are not implemented yet.") + } + if (number_of_newton_steps > 0) { + cli::cli_abort("Newton steps not implemented yet.") + } + if (number_of_loops < 0) { + cli::cli_abort("number_of_loops ({.par {number_of_loops}}) must be >= 0.") + } + obj <- MakeADFun( + data = list(), + parameters = input$parameters, + map = input$map, + random = input$random, + DLL = "FIMS", + silent = TRUE + ) + if (!optimize) { + initial_fit <- FIMSFit( + input = input, + obj = obj, + timing = c("time_total" = as.difftime(0, units = "secs")) + ) + return(initial_fit) + } + if (!is_fims_verbose()) { + control$trace <- 0 + } + ## optimize and compare + cli::cli_inform(c("v" = "Starting optimization ...")) + t0 <- Sys.time() + opt <- with( + obj, + nlminb( + start = par, + objective = fn, + gradient = gr, + control = control + ) + ) + maxgrad0 <- maxgrad <- max(abs(obj$gr(opt$par))) + if (number_of_loops > 0) { + cli::cli_inform(c( + "i" = "Restarting optimizer {number_of_loops} times to improve gradient." + )) + for (ii in 1:number_of_loops) { + # control$trace is reset to zero regardless of verbosity because the + # differences in values printed out using control$trace will be + # negligible between these different runs and is not worth printing + control$trace <- 0 + opt <- with( + obj, + nlminb( + start = opt[["par"]], + objective = fn, + gradient = gr, + control = control + ) + ) + maxgrad <- max(abs(obj[["gr"]](opt[["par"]]))) + } + div_digit <- cli::cli_div(theme = list(.val = list(digits = 5))) + cli::cli_inform(c( + "i" = "Maximum gradient went from {.val {maxgrad0}} to + {.val {maxgrad}} after {number_of_loops} steps." + )) + cli::cli_end(div_digit) + } + time_optimization <- Sys.time() - t0 + cli::cli_inform(c("v" = "Finished optimization")) + + time_sdreport <- NA + if (get_sd) { + t2 <- Sys.time() + sdreport <- TMB::sdreport(obj) + cli::cli_inform(c("v" = "Finished sdreport")) + time_sdreport <- Sys.time() - t2 + } else { + sdreport <- list() + time_sdreport <- as.difftime(0, units = "secs") + } + + timing <- c( + time_optimization = time_optimization, + time_sdreport = time_sdreport, + time_total = Sys.time() - t0 + ) + fit <- FIMSFit( + input = input, + obj = obj, + opt = opt, + sdreport = sdreport, + timing = timing + ) + print(fit) + if (!is.null(filename)) { + cli::cli_warn(c( + "i" = "Saving output to file is not yet implemented." + )) + # saveRDS(fit, file=file.path(input[["path"]], filename)) + } + return(fit) +} + +#we create an as.list method for this new FIMSFit +setMethod("as.list",signature(x="FIMSFit"),function(x) { + mapply(function(y) { + #apply as.list if the slot is again an user-defined object + #therefore, as.list gets applied recursively + if (inherits(slot(x,y),"FIMSFit")) { + as.list(slot(x,y)) + } else { + #otherwise just return the slot + slot(x,y) + } + }, + slotNames(class(x)), + SIMPLIFY=FALSE) +}) diff --git a/R/fimsframe.R b/R/fimsframe.R index a5bc3c394..a175e9d83 100644 --- a/R/fimsframe.R +++ b/R/fimsframe.R @@ -1,172 +1,476 @@ -# This file defines a parent class and its children by -# (1) setting the class; -# (2) defining methods, using setMethod(); -# (3) setting the validators; and -# (4) establishing the constructors (i.e., functions called by users) -# where only the constructors are documented using roxygen. - -# setClass: ---- +# Developers: ---- + +# This file defines the parent class FIMSFrame and its potential children. The +# class is an S4 class with accessors and validators but no setters. +# +# The top of this file contains the declaration of the FIMSFrame class, which +# is the controller of everything. Then the function FIMSFrame() is how objects +# of that class are created, i.e., the constructor, and how users will interact +# with the class the most. When the returned object from that constructor are +# changed, the call to methods::setClass() that defines the class must also be +# changed. The remainder of the file is set up to help you easily augment this +# class. Follow the step-by-step instructions in order or at least know that +# the functions are present in this order: +# +# 1. Add or remove the slot of interest in the call to `methods::setClass()`, +# e.g., if you are adding a new slot you must declare the slot and the type +# of object that should be expected in that slot; to remove an object from +# the FIMSFrame class you must remove the slot here. +# 2. Add an accessor function, e.g., get_*(), to allow users to access the +# object stored in the new slot; or, remove the accessor function if you +# remove a slot. Some internal accessors are also available, e.g., m_*(), +# and should be used to provide data to a model but should not be used by +# average users. +# 3. If we had setter functions for FIMSFrame, you would add or delete the +# appropriate setter functions next but we do not. Instead, we want users to +# re-run FIMSFrame() when they make any changes to their data, that way all +# of the slots will be updated simultaneously. @nathanvaughan-NOAA mentioned +# during Code club 2024-12-17 that this may be a problem for future use of +# FIMSFrame objects, especially when doing MSE or simulation when there is a +# large overhead in running FIMSFrame and you just want to change a small, +# simple thing in your data and re-run the model. We will cross that bridge +# later. @msupernaw also informed us about the ability to lock an R object +# so it cannot be altered. See https://rdrr.io/r/base/bindenv.html. +# 4. Augment the validator functions to ensure that users do not pass +# incompatible information to FIMSFrame(). +# 5. Augment FIMSFrame() to ensure that the slot is created if you are adding a +# new object or remove the object from the returned object if you are +# removing a slot. + +# TODO: ---- + +# TODO: remove or change get_fleets to return fleet names in alphabetized order +# TODO: n_fleets should store total number of fleets, i.e., fishing + survey +# TODO: make date_formats a local variable +# TODO: document sorting of information in terms of alphabetized fleet order +# TODO: test implement addition of -999 +# TODO: validate that all length-age combinations exist in the conversion matrix + +# methods::setClass: ---- + # Classes are not currently exported, and therefore, do not need documentation. # See the following link if we do want to document them in the future: # https://stackoverflow.com/questions/7368262/how-to-properly-document-s4-class-slots-using-roxygen2 -setClass( +methods::setClass( Class = "FIMSFrame", slots = c( - data = "data.frame", # can use c( ) or list here. + data = "tbl_df", fleets = "numeric", n_years = "integer", ages = "numeric", n_ages = "integer", - weight_at_age = "data.frame", + lengths = "numeric", + n_lengths = "integer", start_year = "integer", end_year = "integer" ) ) -# setMethod: accessors ---- -# Methods for accessing info in the slots - -# for now, only getters are included, not setters. -# setter example where ages is the slot and Person is the class -# setGeneric("age<-", function(x, value) standardGeneric("age<-")) -# setMethod("age<-", "Person", function(x, value) { -# x@age <- value -# x -# }) +# methods::setMethod: accessors ---- +# Methods for accessing info in the slots using get_*() or m_*() -# is it problematic to set the generic for data? not sure... -# but it will not work without set generic -# can't call this data because there is already a generic -setGeneric("get_data", function(x) standardGeneric("get_data")) -setMethod("get_data", "FIMSFrame", function(x) x@data) - -# example: so we can call fleets(obj) instead of obj@fleets -setGeneric("fleets", function(x) standardGeneric("fleets")) -setMethod("fleets", "FIMSFrame", function(x) x@fleets) +#' Get a slot in a FIMSFrame object +#' +#' There is an accessor function for each slot in the S4 class `FIMSFrame`, +#' where the function is named `get_*()` and the star can be replaced with the +#' slot name, e.g., [get_data()]. These accessor functions are the preferred +#' way to access objects stored in the available slots. +#' +#' @param x An object returned from [FIMSFrame()]. +#' @name get_FIMSFrame +#' @keywords FIMSFrame +NULL -setGeneric("n_years", function(x) standardGeneric("n_years")) -setMethod("n_years", "FIMSFrame", function(x) x@n_years) +#' @return +#' [get_data()] returns a data frame of the class `tbl_df` containing data for +#' a FIMS model in a long format. The tibble will potentially have the +#' following columns depending if it fits to ages and lengths or just one of +#' them: +#' `r glue::glue_collapse(colnames(data1), sep = ", ", last = ", and ")`. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_data", function(x) standardGeneric("get_data")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_data", "FIMSFrame", function(x) x@data) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_data", + "data.frame", + function(x) FIMSFrame(x)@data +) -setGeneric("start_year", function(x) standardGeneric("start_year")) -setMethod("start_year", "FIMSFrame", function(x) x@start_year) +#' @return +#' [get_fleets()] returns a vector of integer values specifying which fleets in +#' the model are fishing fleets. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_fleets", function(x) standardGeneric("get_fleets")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_fleets", "FIMSFrame", function(x) x@fleets) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_fleets", + "data.frame", + function(x) FIMSFrame(x)@fleets +) -setGeneric("end_year", function(x) standardGeneric("end_year")) -setMethod("end_year", "FIMSFrame", function(x) x@end_year) +#' @return +#' [get_n_years()] returns an integer specifying the number of years in the +#' model. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_n_years", function(x) standardGeneric("get_n_years")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_n_years", "FIMSFrame", function(x) x@n_years) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_n_years", + "data.frame", + function(x) FIMSFrame(x)@n_years +) -setGeneric("ages", function(x) standardGeneric("ages")) -setMethod("ages", "FIMSFrame", function(x) x@ages) +#' @return +#' [get_start_year()] returns an integer specifying the start year of the +#' model. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric( + "get_start_year", + function(x) standardGeneric("get_start_year") +) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_start_year", "FIMSFrame", function(x) x@start_year) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_start_year", + "data.frame", + function(x) FIMSFrame(x)@start_year +) -setGeneric("n_ages", function(x) standardGeneric("n_ages")) -setMethod("n_ages", "FIMSFrame", function(x) x@n_ages) +#' @return +#' [get_end_year()] returns an integer specifying the end year of the +#' model. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_end_year", function(x) standardGeneric("get_end_year")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_end_year", "FIMSFrame", function(x) x@end_year) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_end_year", + "data.frame", + function(x) FIMSFrame(x)@end_year +) -setGeneric("weight_at_age", function(x) standardGeneric("weight_at_age")) -setMethod("weight_at_age", "FIMSFrame", function(x) x@weight_at_age) +#' @return +#' [get_ages()] returns a vector of age bins used in the model. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_ages", function(x) standardGeneric("get_ages")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_ages", "FIMSFrame", function(x) x@ages) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_ages", + "data.frame", + function(x) FIMSFrame(x)@ages +) -setGeneric("m_weight_at_age", function(x) standardGeneric("m_weight_at_age")) -setMethod( - "m_weight_at_age", "FIMSFrame", - function(x) { - dplyr::filter( - .data = as.data.frame(x@data), - .data[["type"]] == "weight-at-age" - ) |> - dplyr::group_by(.data[["age"]]) |> - dplyr::summarize(mean_value = mean(.data[["value"]])) |> - dplyr::pull(.data[["mean_value"]]) - } +#' @return +#' [get_n_ages()] returns an integer specifying the number of age bins used in +#' the model. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_n_ages", function(x) standardGeneric("get_n_ages")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_n_ages", "FIMSFrame", function(x) x@n_ages) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_n_ages", + "data.frame", + function(x) FIMSFrame(x)@n_ages ) -setGeneric("m_ages", function(x) standardGeneric("m_ages")) -setMethod("m_ages", "FIMSFrame", function(x) { - x@ages -}) +#' @return +#' [get_lengths()] returns a vector of length bins used in the model. +#' @export +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric("get_lengths", function(x) standardGeneric("get_lengths")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_lengths", "FIMSFrame", function(x) x@lengths) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_lengths", + "data.frame", + function(x) FIMSFrame(x)@lengths +) -#' Get the landings data to be used in the model -#' -#' @param x The object containing landings. +#' @return +#' [get_n_lengths()] returns an integer specifying the number of length bins +#' used in the model. #' @export -setGeneric("m_landings", function(x) standardGeneric("m_landings")) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setGeneric( + "get_n_lengths", + function(x) standardGeneric("get_n_lengths") +) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod("get_n_lengths", "FIMSFrame", function(x) x@n_lengths) +#' @rdname get_FIMSFrame +#' @keywords FIMSFrame +methods::setMethod( + "get_n_lengths", + "data.frame", + function(x) FIMSFrame(x)@n_lengths +) -#' Get the landings data to be used in the model +#' Get a vector of data to be passed to a FIMS module from a FIMSFrame object +#' +#' There is an accessor function for each data type needed to run a FIMS model. +#' A FIMS model accepts vectors of data and thus each of the `m_*()` functions, +#' where the star can be replaced with the data type separated by underscores, +#' e.g., weight_at_age. These accessor functions are the preferred way to pass +#' data to a FIMS module because the data will have the appropriate indexing. #' -#' @param x The FIMSFrame object containing landings. +#' @details +#' Age-to-length-conversion data, i.e., the proportion of age "a" that are +#' length "l", are used to convert lengths (input data) to ages (modeled) as +#' a way to fit length data without estimating growth. +#' +#' @inheritParams get_data +#' @param fleet_name A string, or vector of strings, specifying the name of the +#' fleet(s) of interest that you want landings data for. The strings must +#' exactly match strings in the column `"name"` of `get_data(x)`. +#' @return +#' All of the `m_*()` functions return vectors of data. Currently, the order of +#' the data is the same order as the data frame because no arranging is done in +#' [FIMSFrame()] and the function just extracts the appropriate column. +#' @name m_ +#' @keywords FIMSFrame +NULL + #' @export -setMethod( +#' @rdname m_ +#' @keywords FIMSFrame +methods::setGeneric( + "m_landings", + function(x, fleet_name) standardGeneric("m_landings") +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( "m_landings", "FIMSFrame", - function(x) { + function(x, fleet_name) { dplyr::filter( .data = x@data, - .data[["type"]] == "landings" + .data[["type"]] == "landings", + .data[["name"]] %in% fleet_name ) |> dplyr::pull(.data[["value"]]) } ) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_landings", + "data.frame", + function(x, fleet_name) m_landings(FIMSFrame(x), fleet_name) +) -#' Get the index data to be used in the model -#' -#' @param x The object containing index. -#' @param fleet_name The name of the fleet for the index data. -#' @export -setGeneric("m_index", function(x, fleet_name) standardGeneric("m_index")) - -#' Get the index data to be used in the model -#' -#' @param x The FIMSFrame object containing index. -#' @param fleet_name The name of the fleet for the index data. #' @export -setMethod( +#' @rdname m_ +#' @keywords FIMSFrame +methods::setGeneric( + "m_index", + function(x, fleet_name) standardGeneric("m_index") +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( "m_index", "FIMSFrame", function(x, fleet_name) { dplyr::filter( .data = x@data, .data[["type"]] == "index", - .data[["name"]] == fleet_name + .data[["name"]] %in% fleet_name ) |> dplyr::pull(.data[["value"]]) } ) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_index", + "data.frame", + function(x, fleet_name) m_index(FIMSFrame(x), fleet_name) +) - -#' Get the age-composition data to be used in the model -#' -#' @param x The object containing the age-composition data. -#' @param fleet_name The name of the fleet for the age-composition data. -#' @export -setGeneric("m_agecomp", function(x, fleet_name) standardGeneric("m_agecomp")) -# Should we add name as an argument here? - -#' Get the age-composition data data to be used in the model -#' -#' @param x The FIMSFrame containing age-composition data. -#' @param fleet_name The name of the fleet for the age-composition data. #' @export -setMethod( +#' @rdname m_ +#' @keywords FIMSFrame +methods::setGeneric( + "m_agecomp", + function(x, fleet_name) standardGeneric("m_agecomp") +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( "m_agecomp", "FIMSFrame", function(x, fleet_name) { dplyr::filter( .data = x@data, .data[["type"]] == "age", - .data[["name"]] == fleet_name + .data[["name"]] %in% fleet_name + ) |> + dplyr::pull(.data[["value"]]) + } +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_agecomp", + "data.frame", + function(x, fleet_name) m_agecomp(FIMSFrame(x), fleet_name) +) + +#' @export +#' @rdname m_ +#' @keywords FIMSFrame +methods::setGeneric( + "m_lengthcomp", + function(x, fleet_name) standardGeneric("m_lengthcomp") +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_lengthcomp", + "FIMSFrame", + function(x, fleet_name) { + dplyr::filter( + .data = x@data, + .data[["type"]] == "length", + .data[["name"]] %in% fleet_name ) |> dplyr::pull(.data[["value"]]) } ) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_lengthcomp", + "data.frame", + function(x, fleet_name) m_lengthcomp(FIMSFrame(x), fleet_name) +) + +#' @export +#' @rdname m_ +#' @keywords FIMSFrame +methods::setGeneric( + "m_weight_at_age", + function(x) standardGeneric("m_weight_at_age") +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_weight_at_age", + "FIMSFrame", + function(x) { + dplyr::filter( + .data = as.data.frame(x@data), + .data[["type"]] == "weight-at-age" + ) |> + dplyr::group_by(.data[["age"]]) |> + dplyr::mutate( + value = ifelse(value == -999, NA, value) + ) |> + dplyr::summarize(mean_value = mean(.data[["value"]], na.rm = TRUE)) |> + dplyr::pull(.data[["mean_value"]]) + } +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_weight_at_age", + "data.frame", + function(x) { + m_weight_at_age(FIMSFrame(x)) + } +) + +#' @export +#' @rdname m_ +#' @keywords FIMSFrame +methods::setGeneric( + "m_age_to_length_conversion", + function(x, fleet_name) standardGeneric("m_age_to_length_conversion") +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_age_to_length_conversion", + "FIMSFrame", + function(x, fleet_name) { + if ("length" %in% colnames(x@data)) { + dplyr::filter( + .data = as.data.frame(x@data), + .data[["type"]] == "age-to-length-conversion", + .data[["name"]] %in% fleet_name + ) |> + dplyr::group_by(.data[["age"]], .data[["length"]]) |> + dplyr::summarize( + mean_value = mean(as.numeric(.data[["value"]]), na.rm = TRUE) + ) |> + dplyr::pull(as.numeric(.data[["mean_value"]])) + } + } +) +#' @rdname m_ +#' @keywords FIMSFrame +methods::setMethod( + "m_age_to_length_conversion", + "data.frame", + function(x, fleet_name) m_age_to_length_conversion(FIMSFrame(x), fleet_name) +) -# Note: don't include setters, because for right now, we don't want users to be -# setting ages, fleets, etc. However, we could allow it in the future, if there -# is away to update the object based on changing the fleets? +# methods::setMethod: initialize ---- -# setMethod: initialize ---- -# Not currently using setMethod(f = "initialize") +# Not currently using methods::setMethod(f = "initialize") # because @kellijohnson-NOAA did not quite understand how they actually work. -# setMethod: plot ---- -setMethod( +# methods::setMethod: plot ---- + +methods::setMethod( f = "plot", signature = "FIMSFrame", - definition = function(x) { + definition = function(x, y, ...) { ggplot2::ggplot( data = x@data, mapping = ggplot2::aes( @@ -189,12 +493,13 @@ setMethod( } ) -# setMethod: show ---- -setMethod( +# methods::setMethod: show ---- + +methods::setMethod( f = "show", signature = "FIMSFrame", definition = function(object) { - message("data.frame of class '", class(object), "'") + message("tbl_df of class '", class(object), "'") if (length(object@data) == 0) { return() } @@ -208,15 +513,21 @@ setMethod( "names" ) print(utils::head(object@data)) + cat("additional slots include the following:") for (nm in snames[ordinnames]) { - cat("additional slots: ", nm, ":\n", sep = "") + cat(nm, ":\n", sep = "") print(slot(object, nm)) } } ) -# setValidity ---- -setValidity( +is.FIMSFrame <- function(x) { + inherits(x, "FIMSFrame") +} + +# methods::setValidity ---- + +methods::setValidity( Class = "FIMSFrame", method = function(object) { errors <- character() @@ -225,17 +536,23 @@ setValidity( errors <- c(errors, "data must have at least one row") } + # FIMS models currently cannot run without weight-at-age data + weight_at_age_data <- dplyr::filter(object@data, type == "weight-at-age") + if (NROW(weight_at_age_data) == 0) { + errors <- c(errors, "data must contain data of the type weight-at-age") + } + errors <- c(errors, validate_data_colnames(object@data)) # Add checks for other slots # Check the format for acceptable variants of the ideal yyyy-mm-dd grepl_datestart <- grepl( "[0-9]{1,4}-[0-9]{1,2}-[0-9]{1-2}", - data_mile1[["datestart"]] + object@data[["datestart"]] ) grepl_dateend <- grepl( "[0-9]{1,4}-[0-9]{1,2}-[0-9]{1-2}", - data_mile1[["dateend"]] + object@data[["dateend"]] ) if (!all(grepl_datestart)) { errors <- c(errors, "datestart must be in 'yyyy-mm-dd' format") @@ -277,33 +594,71 @@ validate_data_colnames <- function(data) { if (!"dateend" %in% the_column_names) { errors <- c(errors, "data must contain 'uncertainty'") } - if (!"age" %in% the_column_names) { - errors <- c(errors, "data must contain 'age'") + if (!any(c("age", "length") %in% the_column_names)) { + errors <- c(errors, "data must contain 'ages' and/or 'lengths'") } return(errors) } # Constructors ---- + # All constructors in this file are documented in 1 roxygen file via @rdname. #' Class constructors for `FIMSFrame` and associated child classes #' -#' All constructor functions take a single input and build an object specific to -#' the needs of each model type within \pkg{FIMS}. `FIMSFrame` is the -#' parent class and the associated child classes have additional slots needed -#' for each model type. +#' All constructor functions take a single input and build an object specific +#' to the needs of each model type within \pkg{FIMS}. `FIMSFrame` is the parent +#' class. Future, associated child classes will have the additional slots +#' needed for different types of models. +#' +#' @details +#' ## data +#' The input data are both sorted and expanded before returning them in the +#' data slot. +#' ### Sorting +#' It is important that the order of the rows in the data are correct but it is +#' not expected that the user will do this. Instead, the returned data are +#' sorted using [dplyr::arrange()] before placing them in the data slot. Data +#' are first sorted by data type, placing all weight-at-age data next to other +#' weight-at-age data and all landings data next to landings data. Thus, +#' age-composition data will come first because their type is "age" and "a" is +#' first in the alphabet. All other types will follow according to their order +#' in the alphabet. +#' Next, within each type, data are organized by fleet. So, age-composition +#' information for fleet1 will come before survey1. Next, all data within type +#' and fleet are arranged by datestart, e.g., by year. That is the end of the +#' sorting for time series data like landings and indices. +#' The biological data are further sorted by bin. Thus, age-composition +#' information will be arranged as follows: +#' +#' | type | name | datestart | age | value | +#' |:---- |:--------:|:----------:|:----:|-------:| +#' | age | fleet1 | 2022-01-01 | 1 | 0.3 | +#' | age | fleet1 | 2022-01-01 | 2 | 0.7 | +#' | age | fleet1 | 2023-01-01 | 1 | 0.5 | +#' +#' Length composition-data are sorted the same way but by length bin instead of +#' by age bin. It becomes more complicated for the age-to-length-conversion +#' data, which are sorted by type, name, datestart, age, and then length. So, a +#' full set of length, e.g., length 10, length 20, length 30, etc., is placed +#' together for a given age. After that age, another entire set of length +#' information will be provided for that next age. Once the year is complete +#' for a given fleet then the next year will begin. #' #' @rdname FIMSFrame #' #' @param data A `data.frame` that contains the necessary columns to construct -#' a data frame of a given `FIMSFrame-class`. +#' a `FIMSFrame-class` object. Currently, those columns are +#' `r glue::glue_collapse(colnames(data1), sep = ", ", last = ", and ")`. See +#' the data1 object in FIMS, e.g., `data(data1, package = "FIMS")`. #' #' @return -#' An object of the S4 class `FIMSFrame` or one of its child classes is +#' An object of the S4 class `FIMSFrame` class, or one of its child classes, is #' validated and then returned. All objects will at a minimum have a slot #' called `data` to store the input data frame. Additional slots are dependent -#' on the child class. Use [showClass()] to see all available slots. +#' on the child class. Use [methods::showClass()] to see all available slots. #' @export +#' @keywords FIMSFrame FIMSFrame <- function(data) { errors <- validate_data_colnames(data) if (length(errors) > 0) { @@ -338,26 +693,151 @@ FIMSFrame <- function(data) { unlist(lapply(strsplit(fleets, "fleet"), function(x) x[2])) ) n_fleets <- length(fleets) - # Make empty NA data frames in the format needed to pass to FIMS - # Get the range of ages displayed in the data to use to specify population - # simulation range - ages <- min(data[["age"]], na.rm = TRUE):max(data[["age"]], na.rm = TRUE) + + if ("age" %in% colnames(data)) { + # Forced to use annual age bins because the model is on an annual time step + # FUTURE: allow for different age bins rather than 1 year increment + ages <- min(data[["age"]], na.rm = TRUE):max(data[["age"]], na.rm = TRUE) + } else { + ages <- numeric() + } n_ages <- length(ages) - weight_at_age <- dplyr::filter( - data, - .data[["type"]] == "weight-at-age" + + if ("length" %in% colnames(data)) { + if (all(is.na(data[["length"]]))) { + lengths <- numeric() + } else { + lengths <- sort(unique(data[["length"]])) + lengths <- lengths[!is.na(lengths)] + } + } else { + lengths <- numeric() + } + n_lengths <- length(lengths) + + # Work on filling in missing data with -999 and arrange in the correct + # order so that getting information out with m_*() are correct. + formatted_data <- tibble::as_tibble(data) |> + dplyr::mutate( + year = as.numeric(format(datestart, "%Y")) + ) + missing_time_series <- create_missing_data( + data = formatted_data, + years = years + ) + if ("age" %in% colnames(formatted_data)) { + missing_ages <- create_missing_data( + data = formatted_data, + bins = ages, + years = years, + column = age, + types = c("weight-at-age", "age") + ) + } else { + missing_ages <- missing_time_series[0, ] + } + if ("length" %in% colnames(formatted_data)) { + missing_lengths <- create_missing_data( + data = formatted_data, + bins = lengths, + years = years, + column = length, + types = "length" + ) + } else { + missing_lengths <- missing_time_series[0, ] + } + if ("age-to-length-conversion" %in% formatted_data[["type"]]) { + # Must do this by hand because it is across two dimensions + temp_age_to_length_data <- formatted_data |> + dplyr::group_by(type, name) + missing_age_to_length <- temp_age_to_length_data |> + dplyr::group_by(type, name) |> + dplyr::filter(type %in% "age-to-length-conversion") |> + tidyr::expand(unit, year = years, age = ages, length = lengths) |> + dplyr::anti_join( + y = dplyr::select( + temp_age_to_length_data, + type, name, unit, year, age, length + ), + by = dplyr::join_by(type, name, unit, year, age, length) + ) |> + dplyr::mutate( + value = 0, + datestart = as.Date(sprintf("%04.0f-01-01", year), date_formats), + dateend = as.Date(sprintf("%04.0f-12-31", year), date_formats) + ) |> + dplyr::ungroup() + } else { + missing_age_to_length <- missing_time_series[0, ] + } + missing_data <- dplyr::bind_rows( + missing_time_series, + missing_ages, + missing_lengths, + missing_age_to_length ) + sort_order <- intersect( + c("name", "type", "datestart", "age", "length"), + colnames(formatted_data) + ) + complete_data <- dplyr::full_join( + formatted_data, + missing_data, + by = colnames(missing_data) + ) |> + dplyr::arrange(!!!rlang::parse_exprs(sort_order)) # Fill the empty data frames with data extracted from the data file - out <- new("FIMSFrame", - data = data, + out <- methods::new("FIMSFrame", + data = complete_data, fleets = fleets, n_years = n_years, start_year = start_year, end_year = end_year, ages = ages, n_ages = n_ages, - weight_at_age = weight_at_age + lengths = lengths, + n_lengths = n_lengths ) return(out) } + +# Unexported functions ---- +create_missing_data <- function( + data, + bins, + years, + column, + types = c("landings", "index") +) { + use_this_data <- data |> + dplyr::group_by(type, name) + out_data <- if (missing(bins)) { + # This only pertains to annual data without bins + use_this_data |> + dplyr::filter(type %in% types) |> + tidyr::expand(unit, year = years) |> + dplyr::anti_join( + y = dplyr::select(use_this_data, type, name, unit, year), + by = dplyr::join_by(type, name, unit, year) + ) + } else { + use_this_data |> + dplyr::group_by(type, name) |> + dplyr::filter(type %in% types) |> + tidyr::expand(unit, year = years, {{ column }} := bins) |> + dplyr::anti_join( + y = dplyr::select(use_this_data, type, name, unit, year, {{ column }}), + by = dplyr::join_by(type, name, unit, year, {{ column }}) + ) + } + date_formats <- c("%Y-%m-%d") + out_data |> + dplyr::mutate( + value = -999, + datestart = as.Date(sprintf("%04.0f-01-01", year), date_formats), + dateend = as.Date(sprintf("%04.0f-12-31", year), date_formats) + ) |> + dplyr::ungroup() +} diff --git a/R/initialize_modules.R b/R/initialize_modules.R new file mode 100644 index 000000000..2ef766e85 --- /dev/null +++ b/R/initialize_modules.R @@ -0,0 +1,877 @@ +# To remove the WARNING +# no visible binding for global variable +utils::globalVariables(c( + "type", "name", "value", "unit", "uncertainty", + "datestart", "dateend", "age", "length", "year" +)) + +#' Initialize a generic module +#' +#' @description +#' Initializes a generic module by setting up its fields based on the provided +#' `module_name`. +#' @param parameters A list. Contains parameters and modules required for +#' initialization. +#' @param data An S4 object. FIMS input data. +#' @param module_name A character. Name of the module to initialize (e.g., +#' "population" or "fleet"). +#' @return +#' The initialized module as an object. +#' @noRd +initialize_module <- function(parameters, data, module_name) { + # TODO: how to return all modules between pipes and create links between + # modules? + # # Retrieve all objects in the environment + # objs <- mget(ls()) + # modules <- get_rcpp_modules(objs) + + # Input checks + # Check if parameters is a list and contains the necessary sub-elements + if (!is.list(parameters)) { + cli::cli_abort("The {.var parameters} argument should be a list.") + } else if (!all(c("parameters", "modules") %in% names(parameters))) { + cli::cli_abort(c( + "The {.var parameters} argument must contain both parameters and modules + lists." + )) + } + # Validate module_name + if (!is.character(module_name) || length(module_name) != 1) { + cli::cli_abort("{.var module_name} must be a single character string.") + } + + # Check if module_name exists in the parameters list + if (!module_name %in% c( + names(parameters[["parameters"]]), + names(parameters[["modules"]]) + )) { + cli::cli_abort("{.var module_name} is missing from the {.var parameters}.") + } + + # Define module class and fields + module_class_name <- if (module_name == "population") { + "Population" + } else if (!(module_name %in% names(parameters[["modules"]])) && + (names(module_name) == "selectivity") + ) { + parameters[["modules"]][["fleets"]][[ + module_name + ]][[names(module_name)]][["form"]] + } else if (!(module_name %in% names(parameters[["modules"]])) && + names(module_name) == "Fleet" + ) { + "Fleet" + } else { + parameters[["modules"]][[module_name]][["form"]] + } + + module_class <- get(module_class_name) + module_fields <- names(module_class@fields) + module <- methods::new(module_class) + module_input <- parameters[["parameters"]][[module_name]] + + if (module_class_name == "Fleet") { + module_fields <- setdiff(module_fields, c( + "log_expected_index", + "proportion_catch_numbers_at_age" + )) + + fleet_types <- get_data(data) |> + dplyr::filter(name == module_name) |> + dplyr::pull(type) |> + unique() + + if ("landings" %in% fleet_types) { + module_fields <- setdiff(module_fields, c( + "log_q", + "random_q", + "estimate_q" + )) + } else { + module_fields <- setdiff(module_fields, c( + "log_Fmort" + )) + } + + # TODO: refactor "age-to-length-conversion" in FIMSFrame data and + # "age_length_conversion_matrix" in the Rcpp interface to + # "age_to_legnth_conversion" for consistency + data_distribution_names_for_fleet_i <- names(parameters[["modules"]][["fleets"]][[module_name]][["data_distribution"]]) + if ("age-to-length-conversion" %in% fleet_types && + "LengthComp" %in% data_distribution_names_for_fleet_i) { + age_length_conversion_matrix_value <- FIMS::m_age_to_length_conversion(data, module_name) + module[["age_length_conversion_matrix"]]$resize(length(age_length_conversion_matrix_value)) + # Assign each value to the corresponding position in the parameter vector + for (i in seq_along(age_length_conversion_matrix_value)) { + module[["age_length_conversion_matrix"]][i][["value"]] <- age_length_conversion_matrix_value[i] + } + + # Set the estimation information for the entire parameter vector + module[["age_length_conversion_matrix"]]$set_all_estimable(FALSE) + + module[["age_length_conversion_matrix"]]$set_all_random(FALSE) + } else { + module_fields <- setdiff(module_fields, c( + # Right now we can also remove nlengths because the default is 0 + "nlengths" + )) + } + + module_fields <- setdiff(module_fields, c( + "age_length_conversion_matrix", + "proportion_catch_numbers_at_length" + )) + } + + # Populate fields based on common and specific settings + # TODO: + # - Population interface + # - Update the Population interface to consistently use n_ages and n_years, + # as done in the S4 data1 object. + # - Currently hard-coded `nseason` to 1 using the defaults from FIMS. + # Update as needed. + # - Add n_fleets to data1. Should n_fleets include both + # fishing and survey fleets? Currently, data1@fleets equals 1. + # - Recruitment interface + # - Remove the field estimate_log_devs. It will be set up using the + # set_all_estimable() method instead. + # - Fleet + # - Remove estimate_Fmort, estimate_q, and random_q from the Rcpp interface + # - Reconsider exposing `log_expected_index` and + # `proportion_catch_numbers_at_age` to users. Their IDs are linked with + # index and agecomp distributions. No input values are required. + + non_standard_field <- c( + "ages", "nages", "nlengths", + "estimate_prop_female", + "nyears", "nseasons", "nfleets", "estimate_log_devs", "weights", + "is_survey", "estimate_q", "random_q" + ) + for (field in module_fields) { + if (field %in% non_standard_field) { + # TODO: reorder the list alphabetically + module[[field]] <- switch( + field, + "ages" = get_ages(data), + "nages" = get_n_ages(data), + "nlengths" = get_n_lengths(data), + "estimate_prop_female" = TRUE, + "nyears" = get_n_years(data), + "nseasons" = 1, + "nfleets" = length(parameters[["modules"]][["fleets"]]), + "estimate_log_devs" = module_input[[ + paste0(module_class_name, ".estimate_log_devs") + ]], + "weights" = m_weight_at_age(data), + "is_survey" = !("landings" %in% fleet_types), + "estimate_q" = module_input[[ + paste0(module_class_name, ".log_q.estimated") + ]], + "random_q" = FALSE, + cli::cli_abort(c( + "{.var {field}} is not a valid field in {.var {module_class_name}} + module." + )) + ) + } else { + set_param_vector( + field = field, + module = module, + module_input = module_input + ) + } + } + + return(module) +} + +# TODO: Determine the relationship between distributions and the +# recruitment module, and implement the appropriate logic to retrieve +# distribution information. + +#' Initialize a distribution module +#' +#' @description +#' Initializes a distribution module by setting up its fields based on the +#' distribution name and type. Supports both "data" and "process" types. +#' @param module_input A list. Contains parameters for initializing the +#' distribution. +#' @param distribution_name A character. Name of the distribution to initialize. +#' @param distribution_type A character. Type of distribution, either "data" or +#' "process". +#' @param linked_ids A vector. Named vector of linked IDs required for the +#' distribution, such as data_link and fleet_link for setting up index +#' distribution. +#' @rdname initialize_module +#' @return +#' The initialized distribution module as an object. +#' @noRd +initialize_distribution <- function( + module_input, + distribution_name, + distribution_type = c("data", "process"), + linked_ids +) { + # Input checks + # Check if distribution_name is provided + if (is.null(distribution_name)) { + return(NULL) + } + # Validate module_input + if (!is.list(module_input)) { + cli::cli_abort("{.var module_input} must be a list.") + } + # Validate distribution_type as "data" or "process" + distribution_type <- rlang::arg_match(distribution_type) + # Validate linked_ids as a named vector with required elements for "data" type + if (!is.vector(linked_ids) || + !all(c("data_link", "fleet_link") %in% names(linked_ids)) + ) { + cli::cli_abort( + "{.var linked_ids} must be a named vector containing 'data_link' and + 'fleet_link' for 'data' distribution types." + ) + } + + # Get distribution value and initialize the module + distribution_value <- get(distribution_name) + distribution_module <- methods::new(distribution_value) + distribution_fields <- names(distribution_value@fields) + if (distribution_type == "data") { + distribution_fields <- setdiff( + distribution_fields, + c("expected_values", "x", "dims") + ) + } + + distribution_input_names <- grep( + distribution_name, + names(module_input), + value = TRUE + ) + for (field in distribution_fields) { + set_param_vector( + field = field, module = distribution_module, + module_input = module_input[distribution_input_names] + ) + } + + switch( + distribution_type, + "data" = { + # Data distribution initialization + distribution_module$set_observed_data(linked_ids["data_link"]) + distribution_module$set_distribution_links( + distribution_type, + linked_ids["fleet_link"] + ) + }, + "process" = { + # Process distribution initialization + distribution_module$set_distribution_links("random_effects", linked_ids) + } + ) + + # Final message to confirm success + cli::cli_inform(c( + "i" = "{distribution_name} initialized successfully for + {names(distribution_name)}." + )) + + return(distribution_module) +} + +#' Initialize a recruitment module +#' +#' @description +#' Initializes a recruitment module by setting up fields. This function uses +#' the `initialize_module` function to handle specific requirements for +#' recruitment initialization. +#' @inheritParams initialize_module +#' @return +#' The initialized recruitment module as an object. +#' @noRd +initialize_recruitment <- function(parameters, data) { + module <- initialize_module( + parameters = parameters, + data = data, + module_name = setNames("recruitment", "population") + ) + return(module) +} + +#' Initialize a growth module +#' +#' @description +#' Initializes a growth module by setting up fields. This function uses +#' the `initialize_module` function to handle specific requirements for +#' growth initialization. +#' @inheritParams initialize_module +#' @return +#' The initialized growth module as an object. +#' @noRd +initialize_growth <- function(parameters, data) { + module <- initialize_module( + parameters = parameters, + data = data, + module_name = setNames("growth", "population") + ) + return(module) +} + +#' Initialize a maturity module +#' +#' @description +#' Initializes a maturity module by setting up fields. This function uses +#' the `initialize_module` function to handle specific requirements for +#' maturity initialization. +#' @inheritParams initialize_module +#' @return +#' The initialized maturity module as an object. +#' @noRd +initialize_maturity <- function(parameters, data) { + module <- initialize_module( + parameters = parameters, + data = data, + module_name = setNames("maturity", "population") + ) + return(module) +} + +#' Initialize a population module. +#' +#' @description +#' Initializes a population module by setting up fields. This function uses +#' the `initialize_module` function to handle specific requirements for +#' population initialization. +#' @inheritParams initialize_module +#' @param linked_ids A vector. Named vector of linked IDs required for the +#' population, including IDs for "growth", "maturity", and "recruitment". +#' @return +#' The initialized population module as an object. +#' @noRd +initialize_population <- function(parameters, data, linked_ids) { + if (any(is.na(linked_ids[c("growth", "maturity", "recruitment")]))) { + cli::cli_abort(c( + "{.var linked_ids} for population must include `growth`, `maturity`, and + `recruitment` IDs." + )) + } + + module <- initialize_module( + parameters = parameters, + data = data, + module_name = setNames("population", "population") + ) + + # Link up the recruitment, growth, and maturity modules with + # this population module + module$SetGrowth(linked_ids["growth"]) + module$SetMaturity(linked_ids["maturity"]) + module$SetRecruitment(linked_ids["recruitment"]) + + return(module) +} + +#' Initialize a selectivity module. +#' +#' @description +#' Initializes a selectivity module by setting up fields. This function uses +#' the `initialize_module` function to handle specific requirements for +#' population initialization. +#' @inheritParams initialize_module +#' @param fleet_name A character. Name of the fleet to initialize. +#' @return +#' The initialized selectivity module as an object. +#' @noRd +initialize_selectivity <- function(parameters, data, fleet_name) { + module <- initialize_module( + parameters = parameters, + data = data, + module_name = setNames(fleet_name, "selectivity") + ) + + return(module) +} + +# TODO: Do we want to put initialize_selectivity(), initialize_index(), and +# initial_age_comp() inside of initialize_fleet()? + +#' Initialize a fleet module +#' +#' @description +#' Initializes a fleet module by setting up its fields. It links selectivity, +#' index, and age-composition modules. +#' @inheritParams initialize_module +#' @param fleet_name A character. Name of the fleet to initialize. +#' @param linked_ids A vector. Named vector of linked IDs required for the +#' fleet, including IDs for "selectivity", "index", "age_comp", and "length_comp". +#' @return +#' The initialized fleet module as an object. +#' @noRd +initialize_fleet <- function(parameters, data, fleet_name, linked_ids) { + + module <- initialize_module( + parameters = parameters, + data = data, + module_name = setNames(fleet_name, "Fleet") + ) + + module$SetSelectivity(linked_ids["selectivity"]) + module$SetObservedIndexData(linked_ids["index"]) + + fleet_types <- get_data(data) |> + dplyr::filter(name == fleet_name) |> + dplyr::pull(type) |> + unique() + + # Link the observed age composition data to the fleet module using its associated ID + # if the data type includes "age" and if "AgeComp" exists in the data distribution + # specification + distribution_names_for_fleet <- names(parameters[["modules"]][["fleets"]][[fleet_name]][["data_distribution"]]) + if ("age" %in% fleet_types && + "AgeComp" %in% distribution_names_for_fleet) { + module$SetObservedAgeCompData(linked_ids["age_comp"]) + } + + # Link the observed length composition data to the fleet module using its associated ID + # if the data type includes "length" and if "LengthComp" exists in the data + # distribution specification + if ("length" %in% fleet_types && + "LengthComp" %in% distribution_names_for_fleet) { + module$SetObservedLengthCompData(linked_ids["length_comp"]) + } + return(module) +} + +#' Initialize an index module +#' +#' @description +#' Initializes an index module based on the provided data and fleet name. +#' @inheritParams initialize_module +#' @param fleet_name A character. Name of the fleet for which the index module +#' is initialized. +#' @return +#' The initialized index module as an object. +#' @noRd +initialize_index <- function(data, fleet_name) { + # Check if the specified fleet exists in the data + fleet_exists <- any(get_data(data)["name"] == fleet_name) + if (!fleet_exists) { + cli::cli_abort("Fleet {fleet_name} not found in the data object.") + } + + fleet_type <- dplyr::filter( + .data = as.data.frame(data@data), + name == fleet_name + ) |> + dplyr::distinct(type) |> + dplyr::pull(type) + + + module <- methods::new(Index, get_n_years(data)) + + if ("landings" %in% fleet_type) { + module[["index_data"]] <- m_landings(data, fleet_name) + } else if ("index" %in% fleet_type) { + module[["index_data"]] <- m_index(data, fleet_name) + } else { + cli::cli_abort(c( + "Fleet type `{fleet_type}` is not valid for index module initialization. + Only 'landings' or 'index' are supported." + )) + } + + return(module) +} + +#' Initialize an age-composition module +#' +#' @description +#' Initializes an age-composition module for a specific fleet, +#' setting the age-composition data for the fleet over time. +#' @inheritParams initialize_module +#' @param fleet_name A character. Name of the fleet for which age-composition +#' data is initialized. +#' @return +#' The initialized age-composition module as an object. +#' @noRd +initialize_age_comp <- function(data, fleet_name) { + + # Check if the specified fleet exists in the data + fleet_exists <- any(get_data(data)["name"] == fleet_name) + if (!fleet_exists) { + cli::cli_abort("Fleet {fleet_name} not found in the data object.") + } + + module <- methods::new(AgeComp, get_n_years(data), get_n_ages(data)) + + # Validate that the fleet's age-composition data is available + age_comp_data <- m_agecomp(data, fleet_name) + if (is.null(age_comp_data) || length(age_comp_data) == 0) { + cli::cli_abort(c( + "Age-composition data for fleet `{fleet_name}` is unavailable or empty." + )) + } + + # Assign the age-composition data to the module + # TODO: review the AgeComp interface, do we want to add + # `age_comp_data` as an argument? + + module$age_comp_data <- age_comp_data * dplyr::filter( + .data = as.data.frame(data@data), + name == fleet_name, + type == "age" + ) |> + dplyr::pull(uncertainty) + + return(module) +} + +# TODO: combine initialize_length_comp and initialize_age_comp() into a single +# function, as they share similar code. +#' Initialize a length-composition module +#' +#' @description +#' Initializes a length-composition module for a specific fleet, +#' setting the length-composition data for the fleet over time. +#' @inheritParams initialize_module +#' @param fleet_name A character. Name of the fleet for which length-composition +#' data is initialized. +#' @return +#' The initialized length-composition module as an object. +#' @noRd +initialize_length_comp <- function(data, fleet_name) { + + # Check if the specified fleet exists in the data + fleet_exists <- any(get_data(data)["name"] == fleet_name) + if (!fleet_exists) { + cli::cli_abort("Fleet {fleet_name} not found in the data object.") + } + + module <- methods::new(LengthComp, get_n_years(data), get_n_lengths(data)) + + # Validate that the fleet's length-composition data is available + length_comp_data <- m_lengthcomp(data, fleet_name) + if (is.null(length_comp_data) || length(length_comp_data) == 0) { + cli::cli_abort(c( + "Length-composition data for fleet `{fleet_name}` is unavailable or empty." + )) + } + + # Assign the length-composition data to the module + # TODO: review the LengthComp interface, do we want to add + # `age_comp_data` as an argument? + + module$length_comp_data <- length_comp_data * dplyr::filter( + .data = as.data.frame(data@data), + name == fleet_name, + type == "length" + ) |> + dplyr::pull(uncertainty) + + return(module) +} + +#' Initialize FIMS modules +#' +#' @description +#' Initializes multiple modules within the Fisheries Integrated Modeling System +#' (FIMS), including fleet, recruitment, growth, maturity, and population +#' modules. This function iterates over the provided fleets, setting up +#' necessary sub-modules such as selectivity, index, and age composition. It +#' also sets up distribution models for fishery index and age-composition data. +#' @param parameters A list. Contains parameters and modules required for +#' initialization. +#' @param data An S4 object. FIMS input data. +#' @return +#' A list containing parameters for the initialized FIMS modules, ready for use +#' in TMB modeling. +#' @export +initialize_fims <- function(parameters, data) { + # Validate parameters input + if (missing(parameters) || !is.list(parameters)) { + cli::cli_abort("The {.var parameters} argument must be a non-missing list.") + } + # Clear any previous FIMS settings + clear() + + module_name <- "fleets" + fleet_names <- names(parameters[["modules"]][["fleets"]]) + if (length(fleet_names) == 0) { + cli::cli_abort(c( + "No fleets found in the provided {.var parameters[['modules']]}." + )) + } + + # Initialize lists to store fleet-related objects + fleet <- fleet_selectivity <- + fleet_index <- fleet_index_distribution <- + fleet_age_comp <- fleet_agecomp_distribution <- + fleet_length_comp <- fleet_lengthcomp_distribution <- + vector("list", length(fleet_names)) + + + for (i in seq_along(fleet_names)) { + fleet_selectivity[[i]] <- initialize_selectivity( + parameters = parameters, + data = data, + fleet_name = fleet_names[i] + ) + + fleet_index[[i]] <- initialize_index( + data = data, + fleet_name = fleet_names[i] + ) + + fleet_module_ids <- c( + index = fleet_index[[i]]$get_id(), + selectivity = fleet_selectivity[[i]]$get_id() + ) + + fleet_types <- get_data(data) |> + dplyr::filter(name == fleet_names[i]) |> + dplyr::pull(type) |> + unique() + + # Initialize age composition module if the data type includes "age" and + # if "AgeComp" exists in the data distribution specification + data_distribution_names_for_fleet_i <- names( + parameters[["modules"]][["fleets"]][[fleet_names[i]]][["data_distribution"]] + ) + + if ("age" %in% fleet_types && + "AgeComp" %in% data_distribution_names_for_fleet_i) { + + # Initialize age composition module for the current fleet + fleet_age_comp[[i]] <- initialize_age_comp( + data = data, + fleet_name = fleet_names[i] + ) + + # Add the module ID for the initialized age composition to the list of fleet module IDs + fleet_module_ids <- c( + fleet_module_ids, + c(age_comp = fleet_age_comp[[i]]$get_id()) + ) + } + + # Initialize length composition module if the data type includes "length" and + # if "LengthComp" exists in the data distribution specification + if ("length" %in% fleet_types && + "LengthComp" %in% data_distribution_names_for_fleet_i) { + + # Initialize length composition module for the current fleet + fleet_length_comp[[i]] <- initialize_length_comp( + data = data, + fleet_name = fleet_names[i] + ) + + # Add the module ID for the initialized length composition to the list of fleet module IDs + fleet_module_ids <- c( + fleet_module_ids, + c(length_comp = fleet_length_comp[[i]]$get_id()) + ) + } + + fleet[[i]] <- initialize_fleet( + parameters = parameters, + data = data, + fleet_name = fleet_names[i], + linked_ids = fleet_module_ids + ) + + # TODO: update argument sd to log_sd to match the Rcpp interface + parameter_value_name <- grep( + paste0("log_sd", ".value"), + names(parameters[["parameters"]][[fleet_names[i]]]), + value = TRUE + ) + parameter_estimated_name <- grep( + paste0("log_sd", ".estimated"), + names(parameters[["parameters"]][[fleet_names[i]]]), + value = TRUE + ) + + if (length(parameter_value_name) == 0 || + length(parameter_estimated_name) == 0 + ) { + cli::cli_abort(c( + "Missing required inputs for `log_sd` in fleet `{fleet_name}`." + )) + } + + fleet_index_distribution[[i]] <- initialize_data_distribution( + module = fleet[[i]], + family = lognormal(link = "log"), + sd = list( + value = exp( + parameters[["parameters"]][[fleet_names[i]]][[parameter_value_name]] + ), + estimated = parameters[["parameters"]][[fleet_names[i]]][[parameter_estimated_name]] + ), + data_type = "index" + ) + + if ("age" %in% fleet_types && + "AgeComp" %in% data_distribution_names_for_fleet_i) { + fleet_agecomp_distribution[[i]] <- initialize_data_distribution( + module = fleet[[i]], + family = multinomial(link = "logit"), + data_type = "agecomp" + ) + } + + if ("length" %in% fleet_types && + "LengthComp" %in% data_distribution_names_for_fleet_i) { + fleet_lengthcomp_distribution[[i]] <- initialize_data_distribution( + module = fleet[[i]], + family = multinomial(link = "logit"), + data_type = "lengthcomp" + ) + } + + } + + # Recruitment + # create new module in the recruitment class (specifically Beverton--Holt, + # when there are other options, this would be where the option would be + # chosen) + recruitment <- initialize_recruitment( + parameters = parameters, + data = data + ) + + parameter_name <- names(parameters$modules$recruitment$process_distribution) + field_value_name <- grep( + paste0("log_sd.value"), + names(parameters[["parameters"]][["recruitment"]]), + value = TRUE + ) + field_estimated_name <- grep( + paste0("log_sd.estimated"), + names(parameters[["parameters"]][["recruitment"]]), + value = TRUE + ) + + if (length(field_value_name) == 0 || length(field_estimated_name) == 0) { + cli::cli_abort("Missing required inputs for recruitment distribution.") + } + + recruitment_distribution <- initialize_process_distribution( + module = recruitment, + par = names(parameters$modules$recruitment$process_distribution), + family = gaussian(), + sd = list( + value = parameters[["parameters"]][["recruitment"]][[field_value_name]], + estimated = parameters[["parameters"]][[ + "recruitment" + ]][[field_estimated_name]] + ), + is_random_effect = FALSE + ) + + # Growth + growth <- initialize_growth( + parameters = parameters, + data = data + ) + + # Maturity + maturity <- initialize_maturity( + parameters = parameters, + data = data + ) + + population_module_ids <- c( + recruitment = recruitment$get_id(), + growth = growth$get_id(), + maturity = maturity$get_id() + ) + + # Population + population <- initialize_population( + parameters = parameters, + data = data, + linked_ids = population_module_ids + ) + + # Set-up TMB + CreateTMBModel() + # Create parameter list from Rcpp modules + parameter_list <- list( + parameters = list(p = get_fixed()) + ) + + return(parameter_list) +} + +#' Set parameter vector values based on module input +#' +#' @description +#' This function sets the parameter vector values in a module based on the +#' provided module input, including both initial values and estimation +#' information. +#' @param field A character string specifying the field name of the parameter +#' vector to be updated. +#' @param module A module object in which the parameter vector is to be set. +#' @param module_input A list containing input parameters for the module, +#' including value and estimation information for the parameter vector. +#' @return +#' Modified module object. +#' @noRd +set_param_vector <- function(field, module, module_input) { + # Check if field_name is a non-empty character string + if (missing(field) || !is.character(field) || nchar(field) == 0) { + cli::cli_abort(c( + "The {.var field} argument must be a non-empty character string." + )) + } + + # Check if module is a reference class + if (!is(module, "refClass")) { + cli::cli_abort(c( + "The {.var module} argument must be a reference class created by + {.fn methods::new}." + )) + } + + # Check if module_input is a list + if (!is.list(module_input)) { + cli::cli_abort("The {.var module_input} argument must be a list.") + } + + # Identify the name for the parameter value and estimation fields in + # module_input + field_value_name <- grep( + paste0(field, ".value"), + names(module_input), + value = TRUE + ) + field_estimated_name <- grep( + paste0(field, ".estimated"), + names(module_input), + value = TRUE + ) + + # Check if both value and estimation information are present + if (length(field_value_name) == 0 || length(field_estimated_name) == 0) { + cli::cli_abort(c( + "Missing value or estimation information for {.var field}." + )) + } + + # Extract the value of the parameter vector + field_value <- module_input[[field_value_name]] + + # Resize the field in the module if it has multiple values + if (length(field_value) > 1) module[[field]]$resize(length(field_value)) + + # Assign each value to the corresponding position in the parameter vector + for (i in seq_along(field_value)) { + module[[field]][i][["value"]] <- field_value[i] + } + + # Set the estimation information for the entire parameter vector + module[[field]]$set_all_estimable(module_input[[field_estimated_name]]) +} diff --git a/R/is_fims_verbose.R b/R/is_fims_verbose.R new file mode 100644 index 000000000..346b94bd0 --- /dev/null +++ b/R/is_fims_verbose.R @@ -0,0 +1,26 @@ +#' Should FIMS be verbose? +#' +#' Verbosity is set globally for FIMS using +#' `options(rlib_message_verbosity = "quiet")` to stop the printing of messages +#' from `cli::cli_inform()`. Using a global option allows for verbose to not +#' have to be an argument to every function. All `cli::cli_abort()` messages are +#' printed to the console no matter what the global option is set to. +#' +#' @return +#' A logical is returned where `TRUE` ensures messages from `cli::cli_inform()` +#' are printed to the console. +#' +#' @examples +#' # function is not exported +#' \dontrun{ +#' FIMS:::is_fims_verbose() +#' } +is_fims_verbose <- function() { + verbose_option <- getOption("rlib_message_verbosity", default = "default") + verbose_boolean <- ifelse( + verbose_option %in% c("default", "verbose"), + TRUE, + FALSE + ) + return(verbose_boolean) +} diff --git a/R/zzz.R b/R/zzz.R index 8ccf0a41b..1af6dbc1e 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -3,3 +3,258 @@ Rcpp::loadModule(module = "fims", what = TRUE) .onUnload <- function(libpath) { library.dynam.unload("FIMS", libpath) } + +# Methods for Rcpp +#' Setter for `Rcpp_ParameterVector` +#' +#' In R, indexing starts at one. But, in C++ indexing starts at zero. These +#' functions do the translation for you so you can think in R terms. +#' +#' @param x A numeric vector. +#' @param i An integer specifying the location in R speak, where indexing +#' starts at one, of the vector that you wish to set. +#' @param j Not used with `Rcpp_ParameterVector` because it is a vector. +#' @param value The value you want to set the indexed location to. +#' @return +#' For `[<-`, the index `i` of object `x` is set to `value`. +#' @keywords set_methods +#' @rdname Rcpp_ParameterVector +methods::setMethod( + f = "[<-", + signature = signature( + x = "Rcpp_ParameterVector" + ), + definition = function(x, i, j, value) { + x$set(i - 1, value) # R uses 1-based indexing, C++ uses 0-based indexing + return(x) # Return the modified object + } +) + +#' Get information from Rcpp_ParameterVector +#' +#' In R, indexing starts at one. But, in C++ indexing starts at zero. This +#' function does the translation for you so you can think in R terms. +#' +#' @param x A numeric vector. +#' @param i An integer specifying the location in R speak, where indexing +#' starts at one, of the vector that you wish to get information from. +#' @return +#' For `[`, the index `i` of object `x` is returned. +#' @keywords set_methods +#' @rdname Rcpp_ParameterVector +methods::setMethod( + f = "[", + signature = signature(x = "Rcpp_ParameterVector", i = "numeric"), + definition = function(x, i) { + return(x$get(i - 1)) + } +) + +#' Get the length of an Rcpp_ParameterVector +#' +#' @param x A numeric vector. +#' @return +#' For `length()`, the length of object `x` is returned as an integer. +#' @keywords set_methods +#' @rdname Rcpp_ParameterVector +methods::setMethod( + f = "length", + signature = signature(x = "Rcpp_ParameterVector"), + definition = function(x) { + return(x$size()) + } +) + +#' Get the sum of all entries in an Rcpp_ParameterVector +#' +#' @param x A numeric vector. +#' @return +#' For `sum()`, the sum of object `x` is returned as a numeric value. +#' @keywords set_methods +#' @rdname Rcpp_ParameterVector +methods::setMethod( + f = "sum", + signature = signature(x = "Rcpp_ParameterVector"), + definition = function(x) { + ret <- methods::new(Parameter) + tmp <- 0.0 + for (i in 1:x$size()) { + tmp <- tmp + x[i]$value + } + ret$value <- tmp + return(ret) + } +) + +#' Get the dimensions of an Rcpp_ParameterVector +#' +#' @param x A numeric vector. +#' @return +#' For `dim()`, the dimensions of object `x` is returned as a single integer +#' because there is only one dimension to return for a vector. +#' @keywords set_methods +#' @rdname Rcpp_ParameterVector +methods::setMethod( + f = "dim", + signature = signature(x = "Rcpp_ParameterVector"), + definition = function(x) { + return(x$size()) + } +) + +#' Sets methods for operators under the S4 Generic Group, Ops +#' +#' Ops include Arith (`+`, `-`, `*`, `^`, `%%`, `%/%`, and `/`); +#' Compare (`==`, `>`, `<`, `!=`, `<=`, and `>=`); and +#' Logic (`&`, `|`). +#' +#' @param e1,e2 An Rcpp_Parameter or Rcpp_ParameterVector class object or a +#' numeric vector or value. +#' @return +#' A numeric or logical value(s) depending on the generic and the length of +#' the input values. +#' @keywords set_methods +#' @export +#' @rdname Rcpp_Math +setMethod( + "Ops", + signature(e1 = "Rcpp_Parameter", e2 = "Rcpp_Parameter"), + function(e1, e2) { + ret <- methods::new(Parameter) + ret$value <- methods::callGeneric(e1$value, e2$value) + } +) + +#' @rdname Rcpp_Math +setMethod( + "Ops", + signature(e1 = "Rcpp_Parameter", e2 = "numeric"), + function(e1, e2) { + if (length(e2) != 1) { + stop("Call to operator Ops, value not scalar") + } + ret <- methods::new(Parameter) + ret$value <- methods::callGeneric(e1$value, e2) + } +) + +#' @rdname Rcpp_Math +setMethod("Ops", signature(e1 = "numeric", e2 = "Rcpp_Parameter"), + function(e1, e2) { + if (length(e1) != 1) { + stop("Call to operator Ops, value not scalar") + } + ret <- methods::new(Parameter) + ret$value <- methods::callGeneric(e1, e2$value) + } +) + +#' @rdname Rcpp_Math +setMethod( + "Ops", + signature(e1 = "Rcpp_ParameterVector", e2 = "Rcpp_ParameterVector"), + function(e1, e2) { + if (e1$size() != e2$size()) { + stop("Call to operator Ops, vectors not equal length") + } + ret <- methods::new(ParameterVector, e1$size()) + for (i in 1:e1$size()) { + ret[i]$value <- methods::callGeneric(e1[i]$value, e2[i]$value) + } + return(ret) + } +) + +#' @rdname Rcpp_Math +setMethod( + "Ops", + signature(e1 = "Rcpp_ParameterVector", e2 = "numeric"), + function(e1, e2) { + if (e1$size() != length(e2)) { + if (length(e2) == 1) { + ret <- methods::new(ParameterVector, e1$size()) + for (i in 1:e1$size()) { + ret[i]$value <- methods::callGeneric(e1[i]$value, e2) + } + return(ret) + } + stop("Call to Ops, vectors not equal length") + } + ret <- methods::new(ParameterVector, e1$size()) + for (i in 1:e1$size()) { + ret[i]$value <- methods::callGeneric(e1[i]$value, e2[i]) + } + return(ret) + } +) + +#' @rdname Rcpp_Math +setMethod( + "Ops", + signature(e1 = "numeric", e2 = "Rcpp_ParameterVector"), + function(e1, e2) { + if (length(e1) != e2$size()) { + if (length(e1) == 1) { + ret <- methods::new(ParameterVector, e2$size()) + for (i in 1:e2$size()) { + ret[i]$value <- methods::callGeneric(e1, e2[i]$value) + } + return(ret) + } + stop("Call to operator, vectors not equal length") + } + ret <- methods::new(ParameterVector, e2$size()) + for (i in 1:e2$size()) { + ret[i]$value <- methods::callGeneric(e1[i], e2[i]$value) + } + return(ret) + } +) + +#' Sets methods for math functions for Rcpp_ParameterVector +#' +#' Methods of mathematical functions include trigonometry functions, `abs`, +#' `sign`, `sqrt`, `ceiling`, `floor`, `trunc`, `cummax`, `cumprod`, `cumsum`, +#' `log`, `log10`, `log2`, `log1p`, `exp`, `expm1`, `gamma`, `lgamma`, +#' `digamma`, and `trigamma`. +#' +#' @param x An Rcpp_ParameterVector class object. +#' @return +#' A vector of numeric values. +#' @keywords set_methods +#' @export +#' @rdname Rcpp_Math +setMethod( + "Math", + signature(x = "Rcpp_ParameterVector"), + function(x) { + xx <- methods::new(ParameterVector, x$size()) + for (i in 1:x$size()) { + xx[i]$value <- methods::callGeneric(x[i]$value) + } + return(xx) + } +) + +#' Set methods for summary functions with an Rcpp_ParameterVector +#' +#' Methods of summary functions include `max`, `min`, `range`, `prod`, `sum`, +#' `any`, and `all`. +#' +#' @param x An Rcpp_ParameterVector class object. +#' @return +#' `Summary` returns a single or two numeric or logical values. +#' @export +#' @keywords set_methods +#' @rdname Rcpp_ParameterVector +setMethod( + "Summary", + signature(x = "Rcpp_ParameterVector"), + function(x) { + xx <- methods::new(ParameterVector, x$size()) + for (i in 1:x$size()) { + xx[i]$value <- methods::callGeneric(x[i]$value) + } + return(xx) + } +) diff --git a/README.md b/README.md index d0b426bd4..bf743bbe2 100644 --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ # Overview The repository for development of FIMS. -The NOAA Fisheries Integrated Modeling System is a software system designed and architected to support next-generation fisheries stock assessment, ecosystem, and socioeconomic modeling. A team of experts within NOAA Fisheries is designing and developing the system, and we are advised by the FIMS Council which includes academic, industry, and international partners. The roles of internal and external collaborators are outlined in the [governance section](https://noaa-fims.github.io/collaborative_workflow/fims-governance.html) of our developer guide. We plan to have an operational software system that is released to the public in 2023. In the meantime, users and developers are welcome to submit feedback using Github issues. Please use the issues under [collaborative workflow](https://github.com/NOAA-FIMS/collaborative_workflow/issues) to make suggestions about the [developer guide](https://noaa-fims.github.io/collaborative_workflow/) and the issues under the FIMS software [repo](https://github.com/NOAA-FIMS/FIMS/issues) for software design and development feedback. You can follow the team discussion [here](https://github.com/NOAA-FIMS/FIMS/discussions). +The NOAA Fisheries Integrated Modeling System is a software system designed to support next-generation fisheries stock assessment, ecosystem, and socioeconomic modeling. A team of experts within NOAA Fisheries is designing and developing the system, and we are advised by the FIMS Council which includes academic, industry, and international partners. The roles of internal and external collaborators are outlined in the [governance section](https://noaa-fims.github.io/collaborative_workflow/fims-governance.html) of our developer guide. We plan to have an operational software system that is released to the public in 2023. In the meantime, users and developers are welcome to submit feedback using Github issues. Please use the issues under [collaborative workflow](https://github.com/NOAA-FIMS/collaborative_workflow/issues) to make suggestions about the [developer guide](https://noaa-fims.github.io/collaborative_workflow/) and the issues under the FIMS software [repo](https://github.com/NOAA-FIMS/FIMS/issues) for software design and development feedback. You can follow the team discussion [here](https://github.com/NOAA-FIMS/FIMS/discussions). ## Installing from R @@ -30,11 +30,13 @@ All contributors participating and contributing to the FIMS project are expected **************************** +## Contributors + ## NOAA Disclaimer This repository is a scientific product and is not official communication of the National Oceanic and Atmospheric Administration, or the United States Department of Commerce. All NOAA GitHub project code is provided on an 'as is' basis and the user assumes responsibility for its use. Any claims against the Department of Commerce or Department of Commerce bureaus stemming from the use of this GitHub project will be governed by all applicable Federal law. Any reference to specific commercial products, processes, or services by service mark, trademark, manufacturer, or otherwise, does not constitute or imply their endorsement, recommendation or favoring by the Department of Commerce. The Department of Commerce seal and logo, or the seal and logo of a DOC bureau, shall not be used in any manner to imply endorsement of any commercial product or activity by DOC or the United States Government. -Software code created by U.S. Government employees is not subject to copyright in the United States (17 U.S.C. §105). The United States/Department of Commerce reserve all rights to seek and obtain copyright protection in countries other than the United States for Software authored in its entirety by the Department of Commerce. To this end, the Department of Commerce hereby grants to Recipient a royalty-free, nonexclusive license to use, copy, and create derivative works of the Software outside of the United States. +Software code created by U.S. Government employees is not subject to copyright in the United States (17 U.S.C. section 105). The United States/Department of Commerce reserve all rights to seek and obtain copyright protection in countries other than the United States for Software authored in its entirety by the Department of Commerce. To this end, the Department of Commerce hereby grants to Recipient a royalty-free, nonexclusive license to use, copy, and create derivative works of the Software outside of the United States. **************************** diff --git a/data-raw/data1.R b/data-raw/data1.R new file mode 100644 index 000000000..36092d8ed --- /dev/null +++ b/data-raw/data1.R @@ -0,0 +1,407 @@ +#' Create a simulated data set using OM from model comparison project +#' +#' Use a simulated data set from {ASSAMC} to create an input data set +#' for an age-structured stock assessment model fit using {FIMS}. +#' +#' @details +#' * This script would need to be augmented to accommodate more than +#' one one fleet or one survey. +#' * Timing: +#' * Fishery is assumed to operate over the entire year +#' * Survey occurs instantaneously at the start of the year +#' +#' @author Kathryn L. Doering and Kelli F. Johnson +#' +############################################################################### +# Helper functions and load packages +############################################################################### +cv_2_sd <- function(x) { + sqrt(log(x^2 + 1)) +} + +check_ASSAMC <- function() { + packages_all <- .packages(all.available = TRUE) + if (!"ASSAMC" %in% packages_all) { + remotes::install_github( + "Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison" + ) + } + library("ASSAMC") + return(TRUE) +} + +check_ASSAMC() +library(dplyr) + +############################################################################### +# Simulate the data +############################################################################### +working_dir <- getwd() + +main_dir <- tempdir() + +# Save the initial OM input using ASSAMC package (sigmaR = 0.4) +model_input <- ASSAMC::save_initial_input() + +# Configure the input parameters for the simulation +sim_num <- 100 +sim_input <- ASSAMC::save_initial_input( + base_case = TRUE, + input_list = model_input, + maindir = main_dir, + om_sim_num = sim_num, + keep_sim_num = sim_num, + figure_number = 1, + seed_num = 9924, + case_name = "sim_data" +) + +# Run OM and generate om_input, om_output, and em_input +# using function from the model comparison project +ASSAMC::run_om(input_list = sim_input) + +setwd(working_dir) + +# Helper function to calculate length at age using the von Bertalanffy growth model +# a: current age +# Linf: asymptotic average length +# K: Growth coefficient +# a_0: Theoretical age at size zero +AtoL <- function(a, Linf, K, a_0) { + L <- Linf * (1 - exp(-K * (a - a_0))) +} + +# Initialize lists for operating model (OM) and estimation model (EM) inputs and outputs +om_input_list <- om_output_list <- em_input_list <- + vector(mode = "list", length = sim_num) + +# Loop through each simulation to generate length data +for (iter in 1:sim_num) { + # Load the OM data for the current simulation + load(file.path(main_dir, "sim_data", "output", "OM", paste0("OM", iter, ".RData"))) + + # Extract von Bertalanffy growth model parameters from the OM input + Linf <- om_input[["Linf"]] + K <- om_input[["K"]] + a0 <- om_input[["a0"]] + amax <- max(om_input[["ages"]]) + # Define coefficient of variation for length-at-age + cv <- 0.1 + # Extract length-weight coefficient from OM + L2Wa <- om_input[["a.lw"]] + # Extract length-weight exponent from OM + L2Wb <- om_input[["b.lw"]] + + # Extract age bins from the OM input + ages <- om_input[["ages"]] + # Define length bins in intervals of 50 + len_bins <- seq(0, 1100, 50) + + # Create length at age conversion matrix and fill proportions using above + # growth parameters + age_to_length_conversion <- matrix(NA, nrow = length(ages), ncol = length(len_bins)) + for (age in seq_along(ages)) { + # Calculate mean length at age to spread lengths around + mean_length <- AtoL(ages[age], Linf, K, a0) + # mean_length <- AtoLSchnute(ages[age],L1,L2,a1,a2,Ks) + # Calculate the cumulative proportion shorter than each composition length + temp_len_probs <- pnorm(q = len_bins, mean = mean_length, sd = mean_length * cv) + # Reset the first length proportion to zero so the first bin includes all + # density smaller than that bin + temp_len_probs[1] <- 0 + # subtract the offset length probabilities to calculate the proportion in each + # bin. For each length bin the proportion is how many fish are larger than this + # length but shorter than the next bin length. + temp_len_probs <- c(temp_len_probs[-1], 1) - temp_len_probs + age_to_length_conversion[age, ] <- temp_len_probs + } + colnames(age_to_length_conversion) <- len_bins + rownames(age_to_length_conversion) <- ages + + # Loop through each simulation to load the results from the corresponding + # .RData files + # Assign the conversion matrix and other information to the OM input + om_input[["lengths"]] <- len_bins + om_input[["nlengths"]] <- length(len_bins) + om_input[["cv.length_at_age"]] <- cv + om_input[["age_to_length_conversion"]] <- age_to_length_conversion + + om_output[["L.length"]] <- list() + om_output[["survey_length_comp"]] <- list() + om_output[["N.length"]] <- matrix(0, nrow = om_input[["nyr"]], ncol = length(len_bins)) + om_output[["L.length"]][["fleet1"]] <- matrix(0, nrow = om_input[["nyr"]], ncol = length(len_bins)) + om_output[["survey_length_comp"]][["survey1"]] <- matrix(0, nrow = om_input[["nyr"]], ncol = length(len_bins)) + + em_input[["L.length.obs"]] <- list() + em_input[["survey.length.obs"]] <- list() + em_input[["L.length.obs"]][["fleet1"]] <- matrix(0, nrow = om_input[["nyr"]], ncol = length(len_bins)) + em_input[["survey.length.obs"]][["survey1"]] <- matrix(0, nrow = om_input[["nyr"]], ncol = length(len_bins)) + + em_input[["lengths"]] <- len_bins + em_input[["nlengths"]] <- length(len_bins) + em_input[["cv.length_at_age"]] <- cv + em_input[["age_to_length_conversion"]] <- age_to_length_conversion + em_input[["n.L.lengthcomp"]][["fleet1"]] <- em_input[["n.survey.lengthcomp"]][["survey1"]] <- 200 + + # Populate length-based outputs for each year, length bin, and age + for (i in seq_along(om_input[["year"]])) { + for (j in seq_along(len_bins)) { + for (k in seq_along(om_input[["ages"]])) { + # Calculate numbers and landings at length for each fleet and survey + om_output[["N.length"]][i, j] <- om_output[["N.length"]][i, j] + + age_to_length_conversion[k, j] * + om_output[["N.age"]][i, k] + + om_output[["L.length"]][[1]][i, j] <- om_output[["L.length"]][[1]][i, j] + + age_to_length_conversion[k, j] * + om_output[["L.age"]][[1]][i, k] + + om_output[["survey_length_comp"]][[1]][i, j] <- om_output[["survey_length_comp"]][[1]][i, j] + + age_to_length_conversion[k, j] * + om_output[["survey_age_comp"]][[1]][i, k] + + em_input[["L.length.obs"]][[1]][i, j] <- em_input[["L.length.obs"]][[1]][i, j] + + age_to_length_conversion[k, j] * + em_input[["L.age.obs"]][[1]][i, k] + + em_input[["survey.length.obs"]][[1]][i, j] <- em_input[["survey.length.obs"]][[1]][i, j] + + age_to_length_conversion[k, j] * + em_input[["survey.age.obs"]][[1]][i, k] + } + } + } + + # Save updated inputs and outputs to file + save( + om_input, om_output, em_input, + file = file.path(main_dir, "sim_data", "output", "OM", paste0("OM", iter, ".RData")) + ) + # Store inputs and outputs in respective lists + om_input_list[[iter]] <- om_input + om_output_list[[iter]] <- om_output + em_input_list[[iter]] <- em_input +} + +# Save all simulations to a single file for {testthat} integration tests +save(om_input_list, om_output_list, em_input_list, + file = testthat::test_path("fixtures", "integration_test_data.RData") +) + +# Load a specific simulation for further processing +sim_id <- 1 +load(file.path(main_dir, "sim_data", "output", "OM", paste0("OM", sim_id, ".RData"))) + +# Return the loaded data +returnedom <- list( + om_input = om_input, + om_output = om_output, + em_input = em_input +) + +############################################################################### +# Landings +############################################################################### +landings_data <- data.frame( + # TODO: Should there be a type that are not removed but just noted, + # where obviously in this instance they are removed. + type = "landings", + name = names(returnedom[["om_output"]][["L.mt"]])[1], + age = NA, # Not by age in this case, but there is a by age option. + datestart = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + format = "%Y-%m-%d" + ), + dateend = as.Date( + paste(returnedom[["om_input"]][["year"]], 12, 31, sep = "-"), + format = "%Y-%m-%d" + ), + value = returnedom[["em_input"]][["L.obs"]][[1]], + unit = "mt", # metric tons + uncertainty = cv_2_sd(returnedom[["em_input"]][["cv.L"]][[1]]) +) + +############################################################################### +# Survey index +############################################################################### +index_data <- data.frame( + type = "index", + name = names(returnedom[["om_output"]][["survey_index"]])[1], + age = NA, # Not by age in this case, but there is a by age option. + datestart = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + format = "%Y-%m-%d" + ), + dateend = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + format = "%Y-%m-%d" + ), + value = returnedom[["em_input"]][["surveyB.obs"]][[1]], + unit = "mt", + uncertainty = cv_2_sd(returnedom[["em_input"]][["cv.survey"]][[1]]) +) + +############################################################################### +# Age-composition data +############################################################################### +age_data <- rbind( + data.frame( + name = names(returnedom[["em_input"]][["n.L"]]), + returnedom[["em_input"]][["L.age.obs"]][["fleet1"]], + unit = "proportion", + uncertainty = returnedom[["em_input"]][["n.L"]][["fleet1"]], + datestart = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + "%Y-%m-%d" + ), + dateend = as.Date( + paste(returnedom[["om_input"]][["year"]], 12, 31, sep = "-"), + "%Y-%m-%d" + ) + ), + data.frame( + name = names(returnedom[["om_output"]][["survey_age_comp"]])[1], + returnedom[["em_input"]][["survey.age.obs"]][[1]], + unit = "proportion", + uncertainty = returnedom[["om_input"]][["n.survey"]][["survey1"]], + datestart = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + "%Y-%m-%d" + ), + dateend = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + "%Y-%m-%d" + ) + ) +) |> + dplyr::mutate( + type = "age" + ) |> + tidyr::pivot_longer( + cols = dplyr::starts_with("X"), + names_prefix = "X", + names_to = "age", + values_to = "value", + # Convert the "age" column from strings to integers + names_transform = list(age = as.integer) + ) + +############################################################################### +# Weight-at-age data +############################################################################### +timingfishery <- data.frame( + datestart = as.Date( + paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), + "%Y-%m-%d" + ), + dateend = as.Date( + paste(returnedom[["om_input"]][["year"]], 12, 31, sep = "-"), + "%Y-%m-%d" + ) +) +weightsfishery <- data.frame( + type = "weight-at-age", + name = names(returnedom[["em_input"]][["n.L"]]), + age = seq_along(returnedom[["om_input"]][["W.kg"]]), + value = returnedom[["om_input"]][["W.mt"]], + uncertainty = NA, + unit = "mt" +) +weightatage_data <- merge(timingfishery, weightsfishery) + +############################################################################### +# {FIMS} data +############################################################################### +# Add new column for length values and set to NA for all milestone 1 data +data1 <- rbind(landings_data, index_data, age_data, weightatage_data) |> + dplyr::mutate( + length = NA, + .after = "age" + ) + +# Extract years and fleets from milestone 1 data +start_date <- timingfishery[["datestart"]] +end_date <- timingfishery[["dateend"]] +observers <- c("fleet1", "survey1") + +# Create data frame for new fleet and year specific length at age conversion +# proportions. These are identical across years and fleets in this default +# example. +length_age_data <- data.frame( + type = "age-to-length-conversion", + name = rep( + sort(rep(observers, length(len_bins) * length(ages))), + length(start_date) + ), + age = rep( + sort(rep(ages, length(len_bins))), + length(observers) * length(start_date) + ), + length = rep( + len_bins, + length(ages) * length(observers) * length(start_date) + ), + datestart = rep( + start_date, + each = length(len_bins) * length(ages) * length(observers) + ), + dateend = rep( + end_date, + each = length(len_bins) * length(ages) * length(observers) + ), + value = rep( + c(t(returnedom[["em_input"]][["age_to_length_conversion"]])), + length(observers) * length(start_date) + ), + unit = "proportion", + uncertainty = rep( + c( + em_input[["n.L.lengthcomp"]][["fleet1"]], + em_input[["n.survey.lengthcomp"]][["survey1"]] + ), + length(len_bins) * length(ages) * length(start_date) + ) +) + +# Create a length-composition data frame that will be filled by transforming +# the age composition data +length_comp_data <- data.frame( + type = "length", + name = sort(rep(observers, length(len_bins) * length(start_date))), + age = NA, + length = rep(len_bins, length(start_date) * length(observers)), + datestart = rep(rep(start_date, each = length(len_bins)), length(observers)), + dateend = rep(rep(end_date, each = length(len_bins)), length(observers)), + value = c( + c(t(returnedom[["em_input"]][["L.length.obs"]][["fleet1"]])), + c(t(returnedom[["em_input"]][["survey.length.obs"]][["survey1"]])) + ), + unit = "proportion", + uncertainty = rep( + c( + em_input[["n.L.lengthcomp"]][["fleet1"]], + em_input[["n.survey.lengthcomp"]][["survey1"]] + ), + length(len_bins) * length(start_date) + ) +) + +# Add the conversion matrix and length composition data to dataframe +data1 <- rbind(data1, length_comp_data, length_age_data) + +write.csv( + data1, + file.path("FIMS_input_data.csv"), + row.names = FALSE +) +# check csv can be read into R well +test_read <- utils::read.csv(file.path("FIMS_input_data.csv")) +# TODO: check if the following is needed before running expect_equal() +test_read[["datestart"]] <- as.Date(test_read[["datestart"]]) +test_read[["dateend"]] <- as.Date(test_read[["dateend"]]) +testthat::expect_equal(test_read, data1) +unlink("FIMS_input_data.csv") + +usethis::use_data(data1, overwrite = TRUE) +on.exit(unlink(main_dir, recursive = TRUE), add = TRUE) +on.exit(setwd(working_dir), add = TRUE) +rm(list = ls()) diff --git a/data-raw/data_mile1.R b/data-raw/data_mile1.R deleted file mode 100644 index 9326d30f7..000000000 --- a/data-raw/data_mile1.R +++ /dev/null @@ -1,173 +0,0 @@ -#' Create a simulated data set using OM from model comparison project -#' -#' Use a simulated data set from {ASSAMC} to create an input data set -#' for an age-structured stock assessment model fit using {FIMS}. -#' -#' @details -#' * This script would need to be augmented to accommodate more than -#' one one fleet or one survey. -#' * Timing: -#' * Fishery is assumed to operate over the entire year -#' * Survey occurs instantaneously at the start of the year -#' -#' @author Kathryn L. Doering and Kelli F. Johnson -#' -############################################################################### -# Helper functions and load packages -############################################################################### -cv_2_sd <- function(x) { - sqrt(log(x^2 + 1)) -} - -check_ASSAMC <- function() { - packages_all <- .packages(all.available = TRUE) - if (!"ASSAMC" %in% packages_all) { - remotes::install_github( - "Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison" - ) - } - library("ASSAMC") - return(TRUE) -} - -check_ASSAMC() -library(dplyr) - -############################################################################### -# Simulate the data -############################################################################### -returnedom <- ASSAMC::save_om_example() - -############################################################################### -# Landings -############################################################################### -landings_data <- data.frame( - # TODO: Should there be a type that are not removed but just noted, - # where obviously in this instance they are removed. - type = "landings", - name = names(returnedom[["om_output"]]$L.mt)[1], - age = NA, # Not by age in this case, but there is a by age option. - datestart = as.Date( - paste(returnedom[["om_input"]]$year, 1, 1, sep = "-"), - format = "%Y-%m-%d" - ), - dateend = as.Date( - paste(returnedom[["om_input"]]$year, 12, 31, sep = "-"), - format = "%Y-%m-%d" - ), - value = returnedom[["em_input"]]$L.obs[[1]], - unit = "mt", # metric tons - uncertainty = cv_2_sd(returnedom[["em_input"]]$cv.L[[1]]) -) - -############################################################################### -# Survey index -############################################################################### -index_data <- data.frame( - type = "index", - name = names(returnedom[["om_output"]]$survey_index)[1], - age = NA, # Not by age in this case, but there is a by age option. - datestart = as.Date( - paste(returnedom[["om_input"]]$year, 1, 1, sep = "-"), - format = "%Y-%m-%d" - ), - dateend = as.Date( - paste(returnedom[["om_input"]]$year, 1, 1, sep = "-"), - format = "%Y-%m-%d" - ), - value = returnedom[["em_input"]]$surveyB.obs[[1]], - unit = "mt", - uncertainty = cv_2_sd(returnedom[["em_input"]]$cv.survey[[1]]) -) - -############################################################################### -# Age-composition data -############################################################################### -age_data <- rbind( - data.frame( - name = names(returnedom[["em_input"]]$n.L), - returnedom[["em_input"]]$L.age.obs$fleet1, - unit = "proportion", - uncertainty = returnedom[["em_input"]]$n.L$fleet1, - datestart = as.Date( - paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), - "%Y-%m-%d" - ), - dateend = as.Date( - paste(returnedom[["om_input"]][["year"]], 12, 31, sep = "-"), - "%Y-%m-%d" - ) - ), - data.frame( - name = names(returnedom[["om_output"]]$survey_age_comp)[1], - returnedom[["em_input"]]$survey.age.obs[[1]], - unit = "number of fish in proportion", - uncertainty = returnedom[["om_input"]][["n.survey"]][["survey1"]], - datestart = as.Date( - paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), - "%Y-%m-%d" - ), - dateend = as.Date( - paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), - "%Y-%m-%d" - ) - ) -) |> - dplyr::mutate( - type = "age" - ) |> - tidyr::pivot_longer( - cols = dplyr::starts_with("X"), - names_prefix = "X", - names_to = "age", - values_to = "value" - ) - -############################################################################### -# Weight-at-age data -############################################################################### -timingfishery <- data.frame( - datestart = as.Date( - paste(returnedom[["om_input"]][["year"]], 1, 1, sep = "-"), - "%Y-%m-%d" - ), - dateend = as.Date( - paste(returnedom[["om_input"]][["year"]], 12, 31, sep = "-"), - "%Y-%m-%d" - ) -) -weightsfishery <- data.frame( - type = "weight-at-age", - name = names(returnedom[["em_input"]]$n.L), - age = seq_along(returnedom[["om_input"]][["W.kg"]]), - value = returnedom[["om_input"]][["W.mt"]], - uncertainty = NA, - unit = "mt" -) -weightatage_data <- merge(timingfishery, weightsfishery) - -############################################################################### -# {FIMS} data -############################################################################### -data_mile1 <- type.convert( - rbind(landings_data, index_data, age_data, weightatage_data), - as.is = TRUE -) -write.csv(data_mile1, - file.path("FIMS_input_data.csv"), - row.names = FALSE -) - -# check csv can be read into R well -test_read <- read.csv(file.path("FIMS_input_data.csv")) -testthat::expect_equal(test_read, data_mile1) -unlink("FIMS_input_data.csv") - -usethis::use_data(data_mile1, overwrite = TRUE) -rm( - check_ASSAMC, cv_2_sd, - age_data, landings_data, index_data, weightatage_data, - timingfishery, weightsfishery, - data_mile1, returnedom, - test_read -) diff --git a/data/data1.rda b/data/data1.rda new file mode 100644 index 000000000..9d170668f Binary files /dev/null and b/data/data1.rda differ diff --git a/data/data_mile1.rda b/data/data_mile1.rda deleted file mode 100644 index cfdec993a..000000000 Binary files a/data/data_mile1.rda and /dev/null differ diff --git a/inst/WORDLIST b/inst/WORDLIST new file mode 100644 index 000000000..e963584b9 --- /dev/null +++ b/inst/WORDLIST @@ -0,0 +1,66 @@ +Arith +Beverton +BevertonHoltRecruitment +CMD +Codecov +DnormDistribution +EWAAgrowth +FIMSFit +FIMSFrame +Github +JSON +Lifecycle +LogEntry +LogisticMaturity +LogisticMaturityInterface +NOAA +ParameterVector +Rcpp +TMB +agecomp +al +cli +codebase +cov +cummax +cumprod +cumsum +cyclomatic +dateend +datestart +destructors +dev +devs +digamma +doxygen +eg +et +expm +fims +fimsframe +functors +ggplot +github +grey +hpp +lengthcomp +lgamma +lm +lpdf +minimizer +nlmimb +popdy +pre +precompiled +rapidjson +rcpp +repo +reportable +sdreport +stan +tabset +testthat +tibble +trigamma +trunc +vec diff --git a/inst/include/common/data_object.hpp b/inst/include/common/data_object.hpp index b78a67bce..e2cc5768b 100644 --- a/inst/include/common/data_object.hpp +++ b/inst/include/common/data_object.hpp @@ -1,34 +1,10 @@ -/* - * File: data_object.hpp - * - * Author: Matthew Supernaw - * National Oceanic and Atmospheric Administration - * National Marine Fisheries Service - * Email: matthew.supernaw@noaa.gov, andrea.havron@noaa.gov - * - * Created on March 24, 2022, 2:37 PM - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * - * This software is a "United States Government Work" under the terms of the - * United States Copyright Act. It was written as part of the author's official - * duties as a United States Government employee and thus cannot be copyrighted. - * This software is freely available to the public for use. The National Oceanic - * And Atmospheric Administration and the U.S. Government have not placed any - * restriction on its use or reproduction. Although all reasonable efforts have - * been taken to ensure the accuracy and reliability of the software and data, - * the National Oceanic And Atmospheric Administration and the U.S. Government - * do not and cannot warrant the performance or results that may be obtained by - * using this software or data. The National Oceanic And Atmospheric - * Administration and the U.S. Government disclaim all warranties, express or - * implied, including warranties of performance, merchantability or fitness - * for any particular purpose. - * - * Please cite the author(s) in any work or product based on this material. - * +/** + * @file data_object.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ - #ifndef FIMS_COMMON_DATA_OBJECT_HPP #define FIMS_COMMON_DATA_OBJECT_HPP @@ -36,6 +12,7 @@ #include #include "model_object.hpp" +#include "fims_vector.hpp" namespace fims_data_object { @@ -45,7 +22,7 @@ namespace fims_data_object { template struct DataObject : public fims_model_object::FIMSObject { static uint32_t id_g; /**< id of the Data Object >*/ - std::vector data; /**< vector of the data >*/ + fims::Vector data; /**< vector of the data >*/ size_t dimensions; /**< dimension of the Data object >*/ size_t imax; /**<1st dimension of data object >*/ size_t jmax; /**< 2nd dimension of data object>*/ diff --git a/inst/include/common/def.hpp b/inst/include/common/def.hpp index a11caf85e..75a31f746 100644 --- a/inst/include/common/def.hpp +++ b/inst/include/common/def.hpp @@ -1,12 +1,9 @@ -/** \file def.hpp - */ - -/* - * File: def.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. +/** + * @file def.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef DEF_HPP #define DEF_HPP @@ -14,28 +11,70 @@ #include #include #include +#include +#include + + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + + +#if defined(linux) || defined(__linux) || defined(__linux__) +#define FIMS_LINUX +#elif defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__DragonFly__) +#define FIMS_BSD +#elif defined(sun) || defined(__sun) +#define FIMS_SOLARIS +#elif defined(__sgi) +#define FIMS_IRIX +#elif defined(__hpux) +#define FIMS_HPUX +#elif defined(__CYGWIN__) +#define FIMS_CYGWIN +#elif defined(_WIN32) || defined(__WIN32__) || defined(WIN32) +#define FIMS_WIN32 +#elif defined(_WIN64) || defined(__WIN64__) || defined(WIN64) +#define FIMS_WIN64 +#elif defined(__BEOS__) +#define FIMS_BEOS +#elif defined(macintosh) || defined(__APPLE__) || defined(__APPLE_CC__) +#define FIMS_MACOS +#elif defined(__IBMCPP__) || defined(_AIX) +#define FIMS_AIX +#elif defined(__amigaos__) +#define FIMS_AMIGAOS +#elif defined(__QNXNTO__) +#define FIMS_QNXNTO +#endif + +#if defined(FIMS_WIN32) || defined(FIMS_WIN64) +#define FIMS_WINDOWS +#endif + +#ifdef FIMS_WINDOWS +#include +#endif + +#if !defined(__PRETTY_FUNCTION__) && !defined(__GNUC__) +#ifdef FIMS_WINDOWS +#define __PRETTY_FUNCTION__ __FUNCTION__ +#endif +#endif // The following rows initialize default log files for outputing model progress // comments used to assist in diagnosing model issues and tracking progress. // These files will only be created if a logs folder is added to the root model // directory. -std::ofstream FIMS_LOG("logs/fims.log"); /**< Generic log file */ -std::ofstream INFO_LOG("logs/info.log"); /**< Information.hpp log file */ -std::ofstream ERROR_LOG("logs/error.log"); /**< Error tracking log file */ -std::ofstream DATA_LOG("logs/data.log"); /**< Data input tracking log file */ -std::ofstream MODEL_LOG("logs/model.log"); /**< Model.hpp log file */ -std::ofstream FLEET_LOG("logs/fleet.log"); /**< Fleet module log file */ -std::ofstream POPULATION_LOG( - "logs/population.log"); /**< Populations module log file */ -std::ofstream RECRUITMENT_LOG( - "logs/recruitment.log"); /**< Recruitment module log file */ -std::ofstream GROWTH_LOG("logs/growth.log"); /**< Growth module log file */ -std::ofstream MATURITY_LOG( - "logs/maturity.log"); /**< Maturity module log file */ -std::ofstream SELECTIVITY_LOG( - "logs/selectivity.log"); /**< Selectivity module log file */ -std::ofstream DEBUG_LOG( - "logs/debug/debug.log"); /**< Development debugging log file */ #ifdef TMB_MODEL // simplify access to singletons @@ -47,31 +86,543 @@ std::ofstream DEBUG_LOG( namespace fims { -/** - * A static class for FIMS logging. - */ + /** + * Log entry. + */ + struct LogEntry { + /** The date/time that the log entry was created, e.g., "Oct 28 09:18:51 2024". You can track how long it took to work through each portion of the model by analyzing the progression of the timestamp through the log file.*/ + std::string timestamp; + /** The description of the log entry, e.g., "Adding Selectivity object to TMB" or "Mismatch dimension error", where the descriptions are predefined in the C++ code. Please make a GitHub issue or contact a developer if you have ideas for a more informative description.*/ + std::string message; + /** The logging level, which is a result of which macro was used to generate the message, e.g., FIMS_INFO_LOG(), FIMS_WARNING_LOG(), or FIMS_ERROR_LOG() results in "info", "warning", or "error", respectively, in the log file. An additional level is available to developers from FIMS_DEBUG_LOG(), resulting in a level of "debug", but this macro is only available in branches other than main.*/ + std::string level; + /** The message id, directly corresponds to the order in which the entries were created, e.g., "1", which is helpful for knowing the order of operations within the code base and comparing log files across model runs.*/ + size_t rank; + /** The user name registered to the computer where the log file was created, e.g., "John.Doe".*/ + std::string user; + /** The working directory for the R environment that created the log file, e.g., "C:/github/NOAA-FIMS/FIMS/vignettes" if you are on a Windows machine or "/home/oppy/FIMS-Testing/dev/dev_logging/FIMS/vignettes" if you are on a linux machine.*/ + std::string wd; + /** The full file path of the file that triggered the log entry, e.g., "C:/github/NOAA-FIMS/FIMS/inst/include/interface/rcpp/rcpp_objects/rcpp_selectivity.hpp".*/ + std::string file; + /** The function or method that led to the initialization the log entry, e.g., "virtual bool LogisticSelectivityInterface::add_to_fims_tmb()". If the function is templated, then the function type will be reported here in square brackets after the function name, e.g., "bool fims_info::Information::CreateModel() [with Type = double]".*/ + std::string routine; + /** The line in `file` where the log entry was initiated, e.g., "219", which will be a line inside of the `routine` listed above.*/ + int line; -class fims_log { - public: - static std::map - FIMS_LOGS; /**< Map Log of files */ - /** - * Static getter for retrieving a specific log file. - */ - static std::ofstream& get(const std::string& l) { - typename std::map::iterator it; - it = fims_log::FIMS_LOGS.find(l); - if (it == fims_log::FIMS_LOGS.end()) { - std::ofstream& of = fims_log::FIMS_LOGS[l]; - of.open(l.c_str()); - } + /** + * Convert this object to a string. + */ + std::string to_string() { + std::stringstream ss; + ss << "\"timestamp\" : " << "\"" << this->timestamp << "\"" << ",\n"; + ss << "\"level\" : " << "\"" << this->level << "\",\n"; + ss << "\"message\" : " << "\"" << this->message << "\",\n"; + ss << "\"id\" : " << "\"" << this->rank << "\",\n"; + ss << "\"user\" : " << "\"" << this->user << "\",\n"; + ss << "\"wd\" : " << "\"" << this->wd << "\",\n"; + ss << "\"file\" : " << "\"" << this->file << "\",\n"; + ss << "\"routine\" : " << "\"" << this->routine << "\",\n"; + ss << "\"line\" : " << "\"" << this->line << "\"\n"; + return ss.str(); + } + + }; + + /** + * FIMS logging class. + */ + class FIMSLog { + std::vector entries; + std::vector log_entries; + size_t entry_number = 0; + std::string path = "fims.log"; + size_t warning_count = 0; + size_t error_count = 0; + + /** + * Get username. + * + * @return username. + */ + std::string get_user() { + char * user; + std::string user_ret = "UNKOWN_USER"; + +#ifdef FIMS_WINDOWS + user = getenv("username"); + user_ret = std::string(user); +#endif +#ifdef FIMS_LINUX + user = getenv("USER"); + user_ret = std::string(user); +#endif + +#ifdef FIMS_MACOS + user = getenv("USER"); + user_ret = std::string(user); +#endif + + return user_ret; + } + public: + bool write_on_exit = true; /*!*/ + bool throw_on_error = false; /*!*/ + static std::shared_ptr fims_log; /*!*/ + + /** + * Default constructor. + */ + FIMSLog() { + + } + + /** + * Destructor. If write_on_exit is set to true, + * the log will be written to the disk in JSON format. + */ + ~FIMSLog() { + if (this->write_on_exit) { + std::ofstream log(this->path); + log << this->get_log(); + log.close(); + } + } + + /** + * @brief Get the Absolute Path Without Dot Dot object + * + * Dot dot notation is for relative paths, where this function replaces + * all dot dots with the actual full path. + * + * @param relativePath A path in your file system. + * @return std::filesystem::path + */ + std::filesystem::path getAbsolutePathWithoutDotDot(const std::filesystem::path& relativePath) { + std::filesystem::path absolutePath = std::filesystem::absolute(relativePath); + + std::filesystem::path result; + for (const auto& part : absolutePath) { + if (part == "..") { + if (!result.empty()) { + result = result.parent_path(); + } + } else { + result /= part; + } + } + + return result.generic_string(); + } + + /** + * Set a path for the log file. + * + * @param path + */ + void set_path(std::string path) { + this->path = path; + } + + /** + * Get the path for the log file. + * + * @return + */ + std::string get_path() { + return this->path; + } + + /** + * Add a "info" level message to the log. + * + * @param str + * @param line + * @param file + * @param func + */ + void info_message(std::string str, int line, const char* file, const char* func) { + std::filesystem::path relativePath = file; + std::filesystem::path absolutePath = getAbsolutePathWithoutDotDot(relativePath); + std::filesystem::path cwd = std::filesystem::current_path(); + std::stringstream ss; + auto now = std::chrono::system_clock::now(); + std::time_t now_time = std::chrono::system_clock::to_time_t(now); + std::string ctime_no_newline = strtok(ctime(&now_time), "\n"); + + LogEntry l; + l.timestamp = ctime_no_newline; + l.message = str; + l.level = "info"; + l.rank = this->log_entries.size(); + l.user = this->get_user(); + l.wd = cwd.generic_string(); + l.file = absolutePath.string(); + l.line = line; + l.routine = func; + this->log_entries.push_back(l); + + } + + /** + * Add a "debug" level message to the log. + * + * @param str + * @param line + * @param file + * @param func + */ + void debug_message(std::string str, int line, const char* file, const char* func) { + std::filesystem::path relativePath = file; + std::filesystem::path absolutePath = getAbsolutePathWithoutDotDot(relativePath); + std::filesystem::path cwd = std::filesystem::current_path(); + std::stringstream ss; + auto now = std::chrono::system_clock::now(); + std::time_t now_time = std::chrono::system_clock::to_time_t(now); + std::string ctime_no_newline = strtok(ctime(&now_time), "\n"); + + LogEntry l; + l.timestamp = ctime_no_newline; + l.message = str; + l.level = "debug"; + l.rank = this->log_entries.size(); + l.user = this->get_user(); + l.wd = cwd.generic_string(); + l.file = absolutePath.string(); + l.line = line; + l.routine = func; + this->log_entries.push_back(l); + + } + + /** + * Add a "error" level message to the log. + * + * @param str + * @param line + * @param file + * @param func + */ + void error_message(std::string str, int line, const char* file, const char* func) { + this->error_count++; + std::filesystem::path relativePath = file; + std::filesystem::path absolutePath = getAbsolutePathWithoutDotDot(relativePath); + std::filesystem::path cwd = std::filesystem::current_path(); + + std::stringstream ss; + auto now = std::chrono::system_clock::now(); + std::time_t now_time = std::chrono::system_clock::to_time_t(now); + std::string ctime_no_newline = strtok(ctime(&now_time), "\n"); + + LogEntry l; + l.timestamp = ctime_no_newline; + l.message = str; + l.level = "error"; + l.rank = this->log_entries.size(); + l.user = this->get_user(); + l.wd = cwd.generic_string(); + l.file = absolutePath.string(); + l.line = line; + l.routine = func; + this->log_entries.push_back(l); + + if (this->throw_on_error) { + std::stringstream ss; + ss << "\n\n" << l.to_string() << "\n\n"; + throw std::runtime_error(ss.str().c_str()); + } + + } + + /** + * Add a "warning" level message to the log. + * + * @param str + * @param line + * @param file + * @param func + */ + void warning_message(std::string str, int line, const char* file, const char* func) { + this->warning_count++; + std::filesystem::path relativePath = file; + std::filesystem::path absolutePath = getAbsolutePathWithoutDotDot(relativePath); + std::filesystem::path cwd = std::filesystem::current_path(); + + std::stringstream ss; + auto now = std::chrono::system_clock::now(); + std::time_t now_time = std::chrono::system_clock::to_time_t(now); + std::string ctime_no_newline = strtok(ctime(&now_time), "\n"); + + LogEntry l; + l.timestamp = ctime_no_newline; + l.message = str; + l.level = "warning"; + l.rank = this->log_entries.size(); + l.user = this->get_user(); + l.wd = cwd.generic_string(); + l.file = absolutePath.string(); + l.line = line; + l.routine = func; + this->log_entries.push_back(l); + + } + + /** + * Get the log as a string object. + * + * @return + */ + std::string get_log() { + std::stringstream ss; + if (log_entries.size() == 0) { + ss << "[\n]"; + } else { + ss << "[\n"; + for (size_t i = 0; i < log_entries.size() - 1; i++) { + ss << "{\n" << this->log_entries[i].to_string() << "},\n"; + + } + ss << "{\n" << this->log_entries[log_entries.size() - 1].to_string() << "}\n]"; + } + return ss.str(); + } + + /** + * Return only error entries from the log. + * + * @return + */ + std::string get_errors() { + std::stringstream ss; + std::vector errors; + for (size_t i = 0; i < log_entries.size(); i++) { + if (log_entries[i].level == "error") { + errors.push_back(this->log_entries[i]); + } + } - return fims_log::FIMS_LOGS[l]; - } -}; + if (errors.size() == 0) { + ss << "[\n]"; + } else { + ss << "[\n"; + for (size_t i = 0; i < errors.size() - 1; i++) { -std::map fims_log::FIMS_LOGS; + ss << "{\n" << errors[i].to_string() << "},\n"; + + } + + ss << "{\n" << errors[errors.size() - 1].to_string() << "}\n]"; + + } + return ss.str(); + } + + /** + * Return only warning entries from the log. + * + * @return + */ + std::string get_warnings() { + std::stringstream ss; + std::vector warnings; + for (size_t i = 0; i < log_entries.size(); i++) { + if (log_entries[i].level == "warning") { + warnings.push_back(this->log_entries[i]); + } + } + + if (warnings.size() == 0) { + ss << "[\n]"; + } else { + ss << "[\n"; + for (size_t i = 0; i < warnings.size() - 1; i++) { + + ss << "{\n" << warnings[i].to_string() << "},\n"; + + } + + ss << "{\n" << warnings[warnings.size() - 1].to_string() << "}\n]"; + + } + return ss.str(); + } + + /** + * Return only info entries from the log. + * + * @return + */ + std::string get_info() { + std::stringstream ss; + std::vector info; + for (size_t i = 0; i < log_entries.size(); i++) { + if (log_entries[i].level == "info") { + info.push_back(this->log_entries[i]); + } + } + + if (info.size() == 0) { + ss << "[\n]"; + } else { + ss << "[\n"; + for (size_t i = 0; i < info.size() - 1; i++) { + + ss << "{\n" << info[i].to_string() << "},\n"; + + } + + ss << "{\n" << info[info.size() - 1].to_string() << "}\n]"; + + } + return ss.str(); + } + + /** + * Query the log by module. + * + * @param module + * @return + */ + std::string get_module(const std::string& module) { + std::stringstream ss; + std::vector info; + for (size_t i = 0; i < log_entries.size(); i++) { + if (log_entries[i].file.find(module) != std::string::npos) { + info.push_back(this->log_entries[i]); + } + } + + if (info.size() == 0) { + ss << "[\n]"; + } else { + ss << "[\n"; + for (size_t i = 0; i < info.size() - 1; i++) { + + ss << "{\n" << info[i].to_string() << "},\n"; + + } + + ss << "{\n" << info[info.size() - 1].to_string() << "}\n]"; + + } + return ss.str(); + } + + /** + * @brief Get the counts of the number of errors + */ + size_t get_error_count() const { + return error_count; + } + + /** + * @brief Get the counts of the number of warnings + */ + size_t get_warning_count() const { + return warning_count; + } + + /** + * @brief Clears all pointers/references of a FIMS model. + * + */ + void clear() { + this->entries.clear(); + this->log_entries.clear(); + this->warning_count = 0; + this->entry_number = 0; + } + + }; + + + std::shared_ptr FIMSLog::fims_log = std::make_shared(); + +} // namespace fims + + + + + +#ifdef FIMS_DEBUG + +#define FIMS_DEBUG_LOG(MESSAGE) FIMSLog::fims_log->debug_message(MESSAGE, __LINE__, __FILE__, __PRETTY_FUNCTION__); + +#else + +#define FIMS_DEBUG_LOG(MESSAGE) /**< Print MESSAGE to debug log */ + +#endif + +#define FIMS_INFO_LOG(MESSAGE) fims::FIMSLog::fims_log->info_message(MESSAGE, __LINE__, __FILE__, __PRETTY_FUNCTION__); /**< Print MESSAGE to info log */ + +#define FIMS_WARNING_LOG(MESSAGE) fims::FIMSLog::fims_log->warning_message(MESSAGE, __LINE__, __FILE__, __PRETTY_FUNCTION__); /**< Print MESSAGE to warning log */ + +#define FIMS_ERROR_LOG(MESSAGE) fims::FIMSLog::fims_log->error_message(MESSAGE, __LINE__, __FILE__, __PRETTY_FUNCTION__); /**< Print MESSAGE to error log */ + +#define FIMS_STR(s) #s /**< String of s */ + + +namespace fims { + + /** + * Signal intercept function. Writes the log to the disk before + * a crash occurs. + * + * @param sig + */ + void WriteAtExit(int sig) { + + std::string signal_error = "NA"; + switch (sig) { + case SIGSEGV: + signal_error = "Invalid memory access (segmentation fault)"; + break; + case SIGINT: + signal_error = "External interrupt, possibly initiated by the user."; + break; + case SIGABRT: + signal_error = "Abnormal termination condition, possible call to std::abort."; + break; + case SIGFPE: + signal_error = "Erroneous arithmetic operation."; + break; + case SIGILL: + signal_error = "Invalid program image or invalid instruction"; + break; + case SIGTERM: + signal_error = "Termination request, sent to the program."; + break; + default: + signal_error = "Unknown signal thrown"; + + } + + FIMSLog::fims_log->error_message(signal_error, -999, "?", "?"); + + + if (FIMSLog::fims_log->write_on_exit) { + + std::ofstream log(FIMSLog::fims_log->get_path()); + log << FIMSLog::fims_log->get_log(); + log.close(); + } + std::signal(sig, SIG_DFL); + raise(sig); + } + + /** + * Converts an object T to a string. + * + * @param v + * @return + */ + template + std::string to_string(T v) { + std::stringstream ss; + ss << v; + return ss.str(); + } -} // namespace fims +} #endif /* TRAITS_HPP */ diff --git a/inst/include/common/fims_math.hpp b/inst/include/common/fims_math.hpp index dcdf42d06..28203f057 100644 --- a/inst/include/common/fims_math.hpp +++ b/inst/include/common/fims_math.hpp @@ -1,28 +1,25 @@ -/** \file fims_math.hpp - */ -// note: To document a global C function, typedef, enum or preprocessor -// definition you must first document the file that contains it - -/* - * File: fims_math.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * +/** + * @file fims_math.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_MATH_HPP #define FIMS_MATH_HPP // note: this is modeling platform specific, must be controlled by // preprocessing macros -//#include "def.hpp" #include +#include +#include #include "../interface/interface.hpp" +#include "fims_vector.hpp" namespace fims_math { #ifdef STD_LIB + /** * @brief The exponential function. * @@ -45,10 +42,24 @@ template inline const Type log(const Type &x) { return std::log(x); } + +template +inline const Type cos(const Type &x) { + return std::cos(x); +} + +template +inline const Type sqrt(const Type &x) { + return std::sqrt(x); +} + +template +inline const Type pow(const Type &x, const Type &y) { + return std::pow(x, y); +} #endif #ifdef TMB_MODEL -// #include /** * @brief The exponential function. @@ -75,7 +86,7 @@ inline const double exp(const double &x) { * -DTMB_MODEL through CMake and Google Test. * @param x the value to take the log of. Please use fims_math::log(x) * if x is an integer. - * @return the log of the value + * @return The natural log of the value. */ template inline const Type log(const Type &x) { @@ -87,6 +98,36 @@ inline const double log(const double &x) { return std::log(x); } +template +inline const Type cos(const Type &x) { + return cos(x); +} + +template <> +inline const double cos(const double &x) { + return std::cos(x); +} + +template +inline const Type sqrt(const Type &x) { + return sqrt(x); +} + +template <> +inline const double sqrt(const double &x) { + return std::sqrt(x); +} + +template +inline const Type pow(const Type &x, const Type &y) { + return pow(x, y); +} + +template <> +inline const double pow(const double &x, const double &y) { + return std::pow(x, y); +} + #endif /** @@ -180,7 +221,7 @@ inline const Type double_logistic(const Type &inflection_point_asc, */ template const Type ad_fabs(const Type &x, Type C = 1e-5) { - return sqrt((x * x) + C); //, .5); + return sqrt((x * x) + C); } /** @@ -220,6 +261,40 @@ inline const Type ad_max(const Type &a, const Type &b, Type C = 1e-5) { return (a + b + fims_math::ad_fabs(a - b, C)) * static_cast(.5); } + /** + * Sum elements of a vector + * + * @brief + * + * @param v A vector of constants. + * @return A single numeric value. + */ + template + T sum(const std::vector& v) { + T ret = 0.0; + for (int i = 0; i < v.size(); i++) { + ret += v[i]; + } + return ret; + } + + /** + * Sum elements of a vector + * + * @brief + * + * @param v A vector of constants. + * @return A single numeric value. + */ + template + T sum(const fims::Vector& v) { + T ret = 0.0; + for (int i = 0; i < v.size(); i++) { + ret += v[i]; + } + return ret; + } + } // namespace fims_math #endif /* FIMS_MATH_HPP */ diff --git a/inst/include/common/fims_vector.hpp b/inst/include/common/fims_vector.hpp index 0892846d4..fca5d33e9 100644 --- a/inst/include/common/fims_vector.hpp +++ b/inst/include/common/fims_vector.hpp @@ -1,8 +1,15 @@ +/** + * @file fims_vector.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ #ifndef FIMS_VECTOR_HPP #define FIMS_VECTOR_HPP #include "../interface/interface.hpp" - +#include namespace fims { /** @@ -16,344 +23,470 @@ namespace fims { */ template class Vector { - std::vector vec_m; - - /** - * @brief friend comparison operator. Allows the operartor to see private - * members of fims::Vector. - */ - template - friend bool operator==(const fims::Vector& lhs, - const fims::Vector& rhs); - - public: - // Member Types - - typedef - typename std::vector::value_type value_type; /*!*/ - typedef typename std::vector::allocator_type - allocator_type; /*!*/ - typedef typename std::vector::size_type size_type; /*!*/ - typedef typename std::vector::difference_type - difference_type; /*!*/ - typedef typename std::vector::reference - reference; /*!*/ - typedef typename std::vector::const_reference - const_reference; /*!*/ - typedef typename std::vector::pointer pointer; /*!*/ - typedef typename std::vector::const_pointer - const_pointer; /*!*/ - typedef typename std::vector::iterator iterator; /*!*/ - typedef typename std::vector::const_iterator - const_iterator; /*!*/ - typedef typename std::vector::reverse_iterator - reverse_iterator; /*!*/ - typedef typename std::vector::const_reverse_iterator - const_reverse_iterator; /*!*/ - - // Constructors - /** - * Default constructor. - */ - Vector() {} - - /** - * @brief Constructs a Vector of length "size" and sets the elements with the - * value from input "value". - */ - Vector(size_t size, const Type& value = Type()) { - this->vec_m.resize(size, value); - } + std::vector vec_m; + + /** + * @brief friend comparison operator. Allows the operartor to see private + * members of fims::Vector. + */ + template + friend bool operator==(const fims::Vector& lhs, + const fims::Vector& rhs); + +public: + // Member Types + + typedef + typename std::vector::value_type value_type; /*!*/ + typedef typename std::vector::allocator_type + allocator_type; /*!*/ + typedef typename std::vector::size_type size_type; /*!*/ + typedef typename std::vector::difference_type + difference_type; /*!*/ + typedef typename std::vector::reference + reference; /*!*/ + typedef typename std::vector::const_reference + const_reference; /*!*/ + typedef typename std::vector::pointer pointer; /*!*/ + typedef typename std::vector::const_pointer + const_pointer; /*!*/ + typedef typename std::vector::iterator iterator; /*!*/ + typedef typename std::vector::const_iterator + const_iterator; /*!*/ + typedef typename std::vector::reverse_iterator + reverse_iterator; /*!*/ + typedef typename std::vector::const_reverse_iterator + const_reverse_iterator; /*!*/ + + // Constructors + + /** + * Default constructor. + */ + Vector() + { + } - /** - * @brief Copy constructor. - */ - Vector(const Vector& other) { - this->vec_m.resize(other.size()); - for (size_t i = 0; i < this->vec_m.size(); i++) { - this->vec_m[i] = other[i]; + /** + * @brief Constructs a Vector of length "size" and sets the elements with the + * value from input "value". + */ + Vector(size_t size, const Type& value = Type()) + { + this->vec_m.resize(size, value); } - } - /** - * @brief Initialization constructor from std::vector type. - */ - Vector(const std::vector& other) { this->vec_m = other; } + /** + * @brief Copy constructor. + */ + Vector(const Vector& other) + { + this->vec_m.resize(other.size()); + for (size_t i = 0; i < this->vec_m.size(); i++) { + this->vec_m[i] = other[i]; + } + } + + /** + * @brief Initialization constructor from std::vector type. + */ + Vector(const std::vector& other) + { + this->vec_m = other; + } - // TMB specific constructor + // TMB specific constructor #ifdef TMB_MODEL - /** - * @brief Initialization constructor from tmbutils::vector type. - */ - Vector(const tmbutils::vector& other) { - this->vec_m.resize(other.size()); - for (size_t i = 0; i < this->vec_m.size(); i++) { - this->vec_m[i] = other[i]; + /** + * @brief Initialization constructor from tmbutils::vector type. + */ + Vector(const tmbutils::vector& other) + { + this->vec_m.resize(other.size()); + for (size_t i = 0; i < this->vec_m.size(); i++) { + this->vec_m[i] = other[i]; + } } - } #endif - /** - * The following are std::vector functions copied over from the standard - * library. While some of these may not be called explicitly in FIMS, they may - * be required to run other std library functions. - */ - - /** - * @brief Returns a reference to the element at specified location pos. No - * bounds checking is performed. - */ - inline Type& operator[](size_t pos) { return this->vec_m[pos]; } - - /** - * @brief Returns a constant reference to the element at specified location - * pos. No bounds checking is performed. - */ - inline const Type& operator[](size_t n) const { return this->vec_m[n]; } - - /** - * @brief Returns a reference to the element at specified location pos. Bounds - * checking is performed. - */ - inline Type& at(size_t n) { return this->vec_m.at(n); } - - /** - * @brief Returns a constant reference to the element at specified location - * pos. Bounds checking is performed. - */ - inline const Type& at(size_t n) const { return this->vec_m.at(n); } - - /** - * @brief Returns a reference to the first element in the container. - */ - inline reference front() { return this->vec_m.front(); } - - /** - * @brief Returns a constant reference to the first element in the container. - */ - inline const_reference front() const { return this->vec_m.front(); } - - /** - * @brief Returns a reference to the last element in the container. - */ - inline reference back() { return this->vec_m.back(); } - - /** - * @brief Returns a constant reference to the last element in the container. - */ - inline const_reference back() const { return this->vec_m.back(); } - - /** - * @brief Returns a pointer to the underlying data array. - */ - inline pointer data() { return this->vec_m.data(); } - - /** - * @brief Returns a constant pointer to the underlying data array. - */ - inline const_pointer data() const { return this->vec_m.data(); } - - // iterators - - /** - * @brief Returns an iterator to the first element of the vector. - */ - inline iterator begin() { return this->vec_m.begin(); } - - /** - * @brief Returns an iterator to the element following the last element of the - * vector. - */ - inline iterator end() { return this->vec_m.end(); } - - /** - * @brief Returns a reverse iterator to the first element of the reversed - * vector. It corresponds to the last element of the non-reversed vector. - */ - inline reverse_iterator rbegin() { return this->vec_m.rbegin(); } - - /** - * @brief Returns a reverse iterator to the element following the last element - * of the reversed vector. It corresponds to the element preceding the first - * element of the non-reversed vector. - */ - inline reverse_iterator rend() { return this->vec_m.rend(); } - - /** - * @brief Returns a constant reverse iterator to the first element of the - * reversed vector. It corresponds to the last element of the non-reversed - * vector. - */ - inline const_reverse_iterator rbegin() const { return this->vec_m.rbegin(); } - - /** - * @brief Returns a constant reverse iterator to the element following the - * last element of the reversed vector. It corresponds to the element - * preceding the first element of the non-reversed vector. - */ - inline const_reverse_iterator rend() const { return this->vec_m.rend(); } - - // capacity - - /** - * @brief Checks whether the container is empty. - */ - inline bool empty() { return this->vec_m.empty(); } - - /** - * @brief Returns the number of elements. - */ - inline size_type size() const { return this->vec_m.size(); } - - /** - * @brief Returns the maximum possible number of elements. - */ - inline size_type max_size() const { return this->vec_m.max_size(); } - - /** - * @brief Reserves storage. - */ - inline void reserve(size_type cap) { this->vec_m.reserve(cap); } - - /** - * @brief Returns the number of elements that can be held in currently - * allocated storage. - */ - inline size_type capacity() { return this->vec_m.capacity(); } - - /** - * @brief Reduces memory usage by freeing unused memory. - */ - inline void shrink_to_fit() { this->vec_m.shrink_to_fit(); } - - // modifiers - - /** - * @brief Clears the contents. - */ - inline void clear() { this->vec_m.clear(); } - - /** - * @brief Inserts value before pos. - */ - inline iterator insert(const_iterator pos, const Type& value) { - return this->vec_m.insert(pos, value); - } + /** + * The following are std::vector functions copied over from the standard + * library. While some of these may not be called explicitly in FIMS, they may + * be required to run other std library functions. + */ + + /** + * @brief Returns a reference to the element at specified location pos. No + * bounds checking is performed. + */ + inline Type& operator[](size_t pos) + { + return this->vec_m[pos]; + } - /** - * @brief Inserts count copies of the value before pos. - */ - inline iterator insert(const_iterator pos, size_type count, - const Type& value) { - return this->vec_m.insert(pos, count, value); - } + /** + * @brief Returns a constant reference to the element at specified location + * pos. No bounds checking is performed. + */ + inline const Type& operator[](size_t n) const + { + return this->vec_m[n]; + } - /** - * @brief Inserts elements from range [first, last) before pos. - */ - template - iterator insert(const_iterator pos, InputIt first, InputIt last) { - return this->vec_m.insert(pos, first, last); - } + /** + * @brief Returns a reference to the element at specified location pos. Bounds + * checking is performed. + */ + inline Type& at(size_t n) + { + return this->vec_m.at(n); + } - /** - * @brief Inserts elements from initializer list ilist before pos. - */ + /** + * @brief Returns a constant reference to the element at specified location + * pos. Bounds checking is performed. + */ + inline const Type& at(size_t n) const + { + return this->vec_m.at(n); + } - iterator insert(const_iterator pos, std::initializer_list ilist) { - return this->vec_m.insert(pos, ilist); - } + /** + * @brief If this vector is size 1 and pos is greater than zero, + * the first index is returned. If this vector has size + * greater than 1 and pos is greater than size, a invalid_argument + * exception is thrown. Otherwise, the value at index pos is returned. + * + * @param pos + * @return a constant reference to the element at specified location + */ + inline Type& get_force_scalar(size_t pos) + { + if (this->size() == 1 && pos > 0) { + return this->at(0); + } else if (this->size() > 1 && pos >= this->size()) { + throw std::invalid_argument("force_get fims::Vector index out of bounds."); + } else { + return this->at(pos); + } + } - /** - * @brief Constructs element in-place. - */ - template - iterator emplace(const_iterator pos, Args&&... args) { - return this->vec_m.emplace(pos, std::forward(args)...); - } + /** + * @brief Returns a reference to the first element in the container. + */ + inline reference front() + { + return this->vec_m.front(); + } - /** - * @brief Removes the element at pos. - */ - inline iterator erase(iterator pos) { return this->vec_m.erase(pos); } + /** + * @brief Returns a constant reference to the first element in the container. + */ + inline const_reference front() const + { + return this->vec_m.front(); + } - /** - * @brief Removes the elements in the range [first, last). - */ - inline iterator erase(iterator first, iterator last) { - return this->vec_m.erase(first, last); - } + /** + * @brief Returns a reference to the last element in the container. + */ + inline reference back() + { + return this->vec_m.back(); + } - /** - * @brief Adds an element to the end. - */ - inline void push_back(const Type&& value) { this->vec_m.push_back(value); } - - /** - * @brief Constructs an element in-place at the end. - */ - template - void emplace_back(Args&&... args) { - this->vec_m.emplace_back(std::forward(args)...); - } + /** + * @brief Returns a constant reference to the last element in the container. + */ + inline const_reference back() const + { + return this->vec_m.back(); + } + + /** + * @brief Returns a pointer to the underlying data array. + */ + inline pointer data() + { + return this->vec_m.data(); + } + + /** + * @brief Returns a constant pointer to the underlying data array. + */ + inline const_pointer data() const + { + return this->vec_m.data(); + } + + // iterators + + /** + * @brief Returns an iterator to the first element of the vector. + */ + inline iterator begin() + { + return this->vec_m.begin(); + } + + /** + * @brief Returns an iterator to the element following the last element of the + * vector. + */ + inline iterator end() + { + return this->vec_m.end(); + } + + /** + * @brief Returns a reverse iterator to the first element of the reversed + * vector. It corresponds to the last element of the non-reversed vector. + */ + inline reverse_iterator rbegin() + { + return this->vec_m.rbegin(); + } + + /** + * @brief Returns a reverse iterator to the element following the last element + * of the reversed vector. It corresponds to the element preceding the first + * element of the non-reversed vector. + */ + inline reverse_iterator rend() + { + return this->vec_m.rend(); + } + + /** + * @brief Returns a constant reverse iterator to the first element of the + * reversed vector. It corresponds to the last element of the non-reversed + * vector. + */ + inline const_reverse_iterator rbegin() const + { + return this->vec_m.rbegin(); + } + + /** + * @brief Returns a constant reverse iterator to the element following the + * last element of the reversed vector. It corresponds to the element + * preceding the first element of the non-reversed vector. + */ + inline const_reverse_iterator rend() const + { + return this->vec_m.rend(); + } + + // capacity + + /** + * @brief Checks whether the container is empty. + */ + inline bool empty() + { + return this->vec_m.empty(); + } + + /** + * @brief Returns the number of elements. + */ + inline size_type size() const + { + return this->vec_m.size(); + } - /** - * @brief Removes the last element. - */ - inline void pop_back() { this->vec_m.pop_back(); } + /** + * @brief Returns the maximum possible number of elements. + */ + inline size_type max_size() const + { + return this->vec_m.max_size(); + } + + /** + * @brief Reserves storage. + */ + inline void reserve(size_type cap) + { + this->vec_m.reserve(cap); + } + + /** + * @brief Returns the number of elements that can be held in currently + * allocated storage. + */ + inline size_type capacity() + { + return this->vec_m.capacity(); + } + + /** + * @brief Reduces memory usage by freeing unused memory. + */ + inline void shrink_to_fit() + { + this->vec_m.shrink_to_fit(); + } + + // modifiers + + /** + * @brief Clears the contents. + */ + inline void clear() + { + this->vec_m.clear(); + } + + /** + * @brief Inserts value before pos. + */ + inline iterator insert(const_iterator pos, const Type& value) + { + return this->vec_m.insert(pos, value); + } + + /** + * @brief Inserts count copies of the value before pos. + */ + inline iterator insert(const_iterator pos, size_type count, + const Type& value) + { + return this->vec_m.insert(pos, count, value); + } + + /** + * @brief Inserts elements from range [first, last) before pos. + */ + template + iterator insert(const_iterator pos, InputIt first, InputIt last) + { + return this->vec_m.insert(pos, first, last); + } + + /** + * @brief Inserts elements from initializer list ilist before pos. + */ + + iterator insert(const_iterator pos, std::initializer_list ilist) + { + return this->vec_m.insert(pos, ilist); + } + + /** + * @brief Constructs element in-place. + */ + template + iterator emplace(const_iterator pos, Args&&... args) + { + return this->vec_m.emplace(pos, std::forward(args)...); + } + + /** + * @brief Removes the element at pos. + */ + inline iterator erase(iterator pos) + { + return this->vec_m.erase(pos); + } + + /** + * @brief Removes the elements in the range [first, last). + */ + inline iterator erase(iterator first, iterator last) + { + return this->vec_m.erase(first, last); + } + + /** + * @brief Adds an element to the end. + */ + inline void push_back(const Type&& value) + { + this->vec_m.push_back(value); + } + + /** + * @brief Constructs an element in-place at the end. + */ + template + void emplace_back(Args&&... args) + { + this->vec_m.emplace_back(std::forward(args)...); + } + + /** + * @brief Removes the last element. + */ + inline void pop_back() + { + this->vec_m.pop_back(); + } - /** - * @brief Changes the number of elements stored. - */ - inline void resize(size_t s) { this->vec_m.resize(s); } + /** + * @brief Changes the number of elements stored. + */ + inline void resize(size_t s) + { + this->vec_m.resize(s); + } - /** - * @brief Swaps the contents. - */ - inline void swap(Vector& other) { this->vec_m.swap(other.vec_m); } + /** + * @brief Swaps the contents. + */ + inline void swap(Vector& other) + { + this->vec_m.swap(other.vec_m); + } - // end std::vector functions + // end std::vector functions - /** - * Conversion operators - */ + /** + * Conversion operators + */ - /** - * @brief Converts fims::Vector to std::vector - */ - inline operator std::vector() { return this->vec_m; } + /** + * @brief Converts fims::Vector to std::vector + */ + inline operator std::vector() + { + return this->vec_m; + } #ifdef TMB_MODEL - /** - * @brief Converts fims::Vector to tmbutils::vectorconst - */ - operator tmbutils::vector() const { - tmbutils::vector ret; - ret.resize(this->vec_m.size()); - for (size_t i = 0; i < this->vec_m.size(); i++) { - ret[i] = this->vec_m[i]; - } - return ret; - } - /** - * @brief Converts fims::Vector to tmbutils::vector - */ - operator tmbutils::vector() { - tmbutils::vector ret; - ret.resize(this->vec_m.size()); - for (size_t i = 0; i < this->vec_m.size(); i++) { - ret[i] = this->vec_m[i]; + /** + * @brief Converts fims::Vector to tmbutils::vectorconst + */ + operator tmbutils::vector() const + { + tmbutils::vector ret; + ret.resize(this->vec_m.size()); + for (size_t i = 0; i < this->vec_m.size(); i++) { + ret[i] = this->vec_m[i]; + } + return ret; + } + + /** + * @brief Converts fims::Vector to tmbutils::vector + */ + operator tmbutils::vector() + { + tmbutils::vector ret; + ret.resize(this->vec_m.size()); + for (size_t i = 0; i < this->vec_m.size(); i++) { + ret[i] = this->vec_m[i]; + } + return ret; } - return ret; - } #endif - private: -}; // end fims::Vector class +private: +}; // end fims::Vector class /** * @brief Comparison operator. @@ -363,6 +496,30 @@ bool operator==(const fims::Vector& lhs, const fims::Vector& rhs) { return lhs.vec_m == rhs.vec_m; } -} // namespace fims +} // namespace fims + +/** + * @brief Output for std::ostream& for a vector. + * + * @param out The stream. + * @param v A vector. + * @return std::ostream& + */ +template +std::ostream& operator<<(std::ostream& out, fims::Vector& v) { + out << "["; + + if (v.size() == 0) { + out << "]"; + return out; + } + for (size_t i = 0; i < v.size() - 1; i++) { + out << v[i] << ","; + } + + out << v[v.size() - 1] << "]"; + return out; +} + #endif diff --git a/inst/include/common/information.hpp b/inst/include/common/information.hpp index a54e23472..99ebeecf9 100644 --- a/inst/include/common/information.hpp +++ b/inst/include/common/information.hpp @@ -1,9 +1,9 @@ -/** \file information.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * +/** + * @file information.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_COMMON_INFORMATION_HPP @@ -12,6 +12,7 @@ #include #include #include +#include #include "../distributions/distributions.hpp" #include "../population_dynamics/fleet/fleet.hpp" @@ -25,536 +26,695 @@ namespace fims_info { -/** - * @brief Stores FIMS model information and creates model. Contains all objects - * and data pre-model construction - */ -template -class Information { - public: - size_t nyears; /**< number of years >*/ - size_t nseasons = 1; /**< number of seasons >*/ - size_t nages; /**< number of ages>*/ - - static std::shared_ptr > - fims_information; /**< singleton instance >*/ - std::vector parameters; /**< list of all estimated parameters >*/ - std::vector - random_effects_parameters; /**< list of all random effects parameters >*/ - std::vector - fixed_effects_parameters; /**< list of all fixed effects parameters >*/ - - // data objects - std::map > > - data_objects; /**< map that holds data objects >*/ - typedef typename std::map< - uint32_t, std::shared_ptr > >::iterator - data_iterator; /**< iterator for the data objects */ - - // life history modules - std::map > > - recruitment_models; /** + class Information { + public: + size_t nyears = 0; /**< number of years >*/ + size_t nseasons = 1; /**< number of seasons >*/ + size_t nages = 0; /**< number of ages>*/ + + static std::shared_ptr > + fims_information; /**< singleton instance >*/ + std::vector parameters; /**< list of all estimated parameters >*/ + std::vector + random_effects_parameters; /**< list of all random effects parameters >*/ + std::vector + fixed_effects_parameters; /**< list of all fixed effects parameters >*/ + std::vector + parameter_names; /**< list of all parameter names estimated in the model */ + + // data objects + std::map > > + data_objects; /**< map that holds data objects >*/ + typedef typename std::map< + uint32_t, std::shared_ptr > >::iterator + data_iterator; /**< iterator for the data objects */ + + // life history modules + std::map > > + recruitment_models; /** > >::iterator - recruitment_models_iterator; - /**< iterator for recruitment objects>*/ + typedef typename std::map< + uint32_t, std::shared_ptr > >::iterator + recruitment_models_iterator; + /**< iterator for recruitment objects>*/ - std::map > > - selectivity_models; /** > > + selectivity_models; /** > >::iterator - selectivity_models_iterator; - /**< iterator for selectivity objects>*/ + typedef typename std::map< + uint32_t, std::shared_ptr > >::iterator + selectivity_models_iterator; + /**< iterator for selectivity objects>*/ - std::map > > - growth_models; /** > > + growth_models; /** > >::iterator - growth_models_iterator; - /**< iterator for growth objects>*/ + typedef typename std::map< + uint32_t, std::shared_ptr > >::iterator + growth_models_iterator; + /**< iterator for growth objects>*/ - std::map > > - maturity_models; /** > > + maturity_models; /** > >::iterator - maturity_models_iterator; - /**< iterator for maturity objects>*/ - - // fleet modules - std::map > > - fleets; /** > >::iterator + maturity_models_iterator; + /**< iterator for maturity objects>*/ + + // fleet modules + std::map > > + fleets; /** > >::iterator - fleet_iterator; - /**< iterator for fleet objects>*/ - - // populations - std::map > > - populations; /** > >::iterator + fleet_iterator; + /**< iterator for fleet objects>*/ + + // populations + std::map > > + populations; /** > >::iterator - population_iterator; - /**< iterator for population objects>*/ - - // distributions - std::map > > - distribution_models; /** > >::iterator + population_iterator; + /**< iterator for population objects>*/ + + // distributions + std::map > > + density_components; /** > >::iterator - distribution_models_iterator; - /**< iterator for distribution objects>*/ - - Information() {} - - virtual ~Information() {} - - /** - * Returns a single Information object for type T. - * - * @return singleton for type T - */ - static std::shared_ptr > GetInstance() { - if (Information::fims_information == nullptr) { - Information::fims_information = - std::make_shared >(); - } - return Information::fims_information; - } - - /** - * Register a parameter as estimable. - * - * @param p - */ - void RegisterParameter(Type& p) { - this->fixed_effects_parameters.push_back(&p); - } - - /** - * Register a random effect as estimable. - * - * @param re - */ - void RegisterRandomEffect(Type& re) { - this->random_effects_parameters.push_back(&re); - } - - /** - * Create the generalized stock assessment model that will evaluate the - * objective function. Does error checking to make sure the program has - * all necessary components for the model and that they're in the right - * dimensions. This sets up pointers to all memory objects and initializes - * fleet and population objects. - * - * @return True if valid model, False if invalid model, check fims.log for - * errors. - */ - bool CreateModel() { - bool valid_model = true; - INFO_LOG << "" << std::endl; - INFO_LOG - << "Beginning to create FIMS model in information.hpp CreateModel(). " - << std::endl; - INFO_LOG << "Initializing fleet objects for " << this->fleets.size() - << " fleets." << std::endl; - for (fleet_iterator it = this->fleets.begin(); it != this->fleets.end(); - ++it) { - // Initialize fleet object - - std::shared_ptr > f = (*it).second; - INFO_LOG << "Initializing fleet " << f->id << "." << std::endl; - - f->Initialize(f->nyears, f->nages); - - INFO_LOG << "Expecting to import " << this->data_objects.size() - << " data objects." << std::endl; - - INFO_LOG << "Checking for available fleet index data objects." - << std::endl; - // set index data - if (f->fleet_observed_index_data_id_m != -999) { - uint32_t observed_index_id = - static_cast(f->fleet_observed_index_data_id_m); - data_iterator it = this->data_objects.find(observed_index_id); - INFO_LOG << "Input fleet index id = " << observed_index_id << "." - << std::endl; - - if (it != this->data_objects.end()) { - f->observed_index_data = (*it).second; - INFO_LOG << "Index data successfully set." << std::endl; - DATA_LOG << "" << std::endl; - DATA_LOG << "Observed input for fleet " << f->id << ", index " - << observed_index_id << ": \n " - << f->observed_index_data->at(1) << std::endl; - } else { - valid_model = false; - ERROR_LOG << "Error: Expected data observations not defined for fleet" - << f->id << ", index " << observed_index_id << std::endl; - exit(1); + typedef typename std::map< + uint32_t, + std::shared_ptr > >::iterator + density_components_iterator; + /**< iterator for distribution objects>*/ + + std::unordered_map* > + variable_map; /*** >::iterator + variable_map_iterator; /**< iterator for variable map>*/ + + Information() { + } + + virtual ~Information() { + } + + /** + * @brief Clears all containers. + * + */ + void Clear(){ + this->data_objects.clear(); + this->density_components.clear(); + this->fixed_effects_parameters.clear(); + this->fleets.clear(); + this->growth_models.clear(); + this->maturity_models.clear(); + this->parameter_names.clear(); + this->parameters.clear(); + this->random_effects_parameters.clear(); + this->recruitment_models.clear(); + this->selectivity_models.clear(); + this->variable_map.clear(); + this->nyears = 0; + this->nseasons = 0; + this->nages = 0; + } + + /** + * @brief Returns a singleton Information object for type T. + * + * @return singleton for type T + */ + static std::shared_ptr > GetInstance() { + if (Information::fims_information == nullptr) { + Information::fims_information = + std::make_shared >(); + } + return Information::fims_information; + } + + /** + * @brief Register a parameter as estimable. + * + * @param p + */ + void RegisterParameter(Type& p) { + this->fixed_effects_parameters.push_back(&p); + } + + /** + * @brief Register a random effect as estimable. + * + * @param re + */ + void RegisterRandomEffect(Type& re) { + this->random_effects_parameters.push_back(&re); + } + + /** + * @brief Register a parameter name. + * + * @param p_name + */ + void RegisterParameterName(std::string p_name) { + this->parameter_names.push_back(p_name); + } + + /** + * @brief Loop over distributions and set links to distribution x value if distribution is a prior type. + */ + void SetupPriors() { + for (density_components_iterator it = density_components.begin(); it != density_components.end(); ++it) { + std::shared_ptr > d = (*it).second; + if (d->input_type == "prior") { + FIMS_INFO_LOG("Setup prior for distribution " + fims::to_string(d->id)); + variable_map_iterator vmit; + FIMS_INFO_LOG("Link prior from distribution " + fims::to_string(d->id) + " to parameter " + fims::to_string(d->key[0])); + vmit = this->variable_map.find(d->key[0]); + d->x = *(*vmit).second; + for (size_t i = 1; i < d->key.size(); i++) { + FIMS_INFO_LOG("Link prior from distribution " + fims::to_string(d->id) + + " to parameter " + fims::to_string(d->key[0])); + vmit = this->variable_map.find(d->key[i]); + d->x.insert(std::end(d->x), + std::begin(*(*vmit).second), std::end(*(*vmit).second)); + } + FIMS_INFO_LOG("Prior size for distribution " + fims::to_string(d->id) + "is: " + fims::to_string(d->x.size())); + } + } + } + + /** + * @brief Loop over distributions and set links to distribution x value if distribution is a random effects type. + */ + void SetupRandomEffects() { + for (density_components_iterator it = this->density_components.begin(); it != this->density_components.end(); ++it) { + std::shared_ptr > d = (*it).second; + if (d->input_type == "random_effects") { + FIMS_INFO_LOG("Setup random effects for distribution " + fims::to_string(d->id)); + variable_map_iterator vmit; + FIMS_INFO_LOG("Link random effects from distribution " + + fims::to_string(d->id) + " to derived value " + fims::to_string(d->key[0])); + vmit = this->variable_map.find(d->key[0]); + d->x = *(*vmit).second; + for (size_t i = 1; i < d->key.size(); i++) { + FIMS_INFO_LOG("Link random effects from distribution " + fims::to_string(d->id) + + " to derived value " + fims::to_string(d->key[0])); + vmit = this->variable_map.find(d->key[i]); + d->x.insert(std::end(d->x), + std::begin(*(*vmit).second), std::end(*(*vmit).second)); + } + FIMS_INFO_LOG("Random effect size for distribution " + fims::to_string(d->id) + " is: " + fims::to_string(d->x.size())); + } + } + } + + /** + * @brief Loop over distributions and set links to distribution expected value if distribution is a data type. + */ + void SetupData() { + for (density_components_iterator it = this->density_components.begin(); it != this->density_components.end(); ++it) { + std::shared_ptr > d = (*it).second; + if (d->input_type == "data") { + FIMS_INFO_LOG("Setup expected value for data distribution " + fims::to_string(d->id)); + variable_map_iterator vmit; + FIMS_INFO_LOG("Link expected value from distribution " + fims::to_string(d->id) + + " to derived value " + fims::to_string(d->key[0])); + vmit = this->variable_map.find(d->key[0]); + d->expected_values = *(*vmit).second; + + for (size_t i = 1; i < d->key.size(); i++) { + vmit = this->variable_map.find(d->key[i]); + FIMS_INFO_LOG("Link expected value from distribution " + + fims::to_string(d->id) + " to derived value " + fims::to_string(d->key[i])); + d->expected_values.insert(std::end(d->expected_values), + std::begin(*(*vmit).second), std::end(*(*vmit).second)); + } + FIMS_INFO_LOG("Expected value size for distribution " + fims::to_string(d->id) + + " is: " + fims::to_string(d->expected_values.size())); + } + } } - } else { - valid_model = false; - ERROR_LOG << "Error: No index data observed for fleet " << f->id - << ". FIMS requires index data for all fleets." << std::endl; - exit(1); - } - // end set index data - - INFO_LOG << "Checking for available fleet age comp data objects." - << std::endl; - // set age composition data - if (f->fleet_observed_agecomp_data_id_m != -999) { - uint32_t observed_agecomp_id = - static_cast(f->fleet_observed_agecomp_data_id_m); - data_iterator it = this->data_objects.find(observed_agecomp_id); - INFO_LOG << "Input fleet age comp id = " << observed_agecomp_id << "." - << std::endl; - - if (it != this->data_objects.end()) { - f->observed_agecomp_data = (*it).second; - INFO_LOG << "Age comp data successfully set." << std::endl; - DATA_LOG << "" << std::endl; - DATA_LOG << "Observed input age comp for fleet " << f->id << ", comp " - << observed_agecomp_id << ": \n " - << f->observed_agecomp_data->at(1) << std::endl; - } else { - valid_model = false; - ERROR_LOG << "Error: Expected age comp data observations not defined " - "for fleet " - << f->id << ", index " << observed_agecomp_id << std::endl; - exit(1); + /** + * @brief Set pointers to index data in the fleet module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param f shared pointer to fleet module + */ + void SetFleetIndexData( + bool &valid_model, + std::shared_ptr > f) { + if (f->fleet_observed_index_data_id_m != -999) { + uint32_t observed_index_id = + static_cast (f->fleet_observed_index_data_id_m); + data_iterator it = this->data_objects.find(observed_index_id); + if (it != this->data_objects.end()) { + f->observed_index_data = (*it).second; + FIMS_INFO_LOG("Index data for fleet " + + fims::to_string(f->id) + " successfully set to " + + fims::to_string(f->observed_index_data->at(1))); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected index data not defined for fleet " + + fims::to_string(f->id) + ", index " + + fims::to_string(observed_index_id)); + } + } else { + valid_model = false; + // TODO: explore why index data is required because it should not be + FIMS_ERROR_LOG("No index data observed for fleet " + + fims::to_string(f->id) + ". FIMS requires index data for all fleets."); + } } - } else { - valid_model = false; - ERROR_LOG << "Error: No age comp data observed for fleet " << f->id - << ". FIMS requires age comp data for all fleets." - << std::endl; - exit(1); - } - // end set composition data - - INFO_LOG << "Checking for available fleet selectivity pattern." - << std::endl; - // set selectivity model - if (f->fleet_selectivity_id_m != -999) { - uint32_t sel_id = static_cast( - f->fleet_selectivity_id_m); // cast as unsigned integer - selectivity_models_iterator it = this->selectivity_models.find( - sel_id); // if find, set it, otherwise invalid - INFO_LOG << "Input fleet selectivity pattern id = " << sel_id << "." - << std::endl; - - if (it != this->selectivity_models.end()) { - f->selectivity = (*it).second; // elements in container held in pair - // (first is id, second is object - - // shared pointer to distribution) - INFO_LOG << "Selectivity successfully set." << std::endl; - } else { - valid_model = false; - ERROR_LOG - << "Error: Expected selectivity pattern not defined for fleet " - << f->id << ", selectivity pattern " << sel_id << std::endl; - exit(1); + /** + * @brief Set pointers to age composition data in the fleet module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param f shared pointer to fleet module + */ + void SetAgeCompositionData( + bool &valid_model, + std::shared_ptr > f) { + if (f->fleet_observed_agecomp_data_id_m != -999) { + uint32_t observed_agecomp_id = + static_cast (f->fleet_observed_agecomp_data_id_m); + data_iterator it = this->data_objects.find(observed_agecomp_id); + if (it != this->data_objects.end()) { + f->observed_agecomp_data = (*it).second; + FIMS_INFO_LOG("Observed input age-composition data for fleet " + + fims::to_string(f->id) + " successfully set to " + + fims::to_string(f->observed_agecomp_data->at(1))); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected age-composition observations not defined for fleet " + + fims::to_string(f->id)); + } + } } - } else { - valid_model = false; - ERROR_LOG << "Error: No selectivity pattern defined for fleet " << f->id - << ". FIMS requires selectivity be defined for all fleets." - << std::endl; - exit(1); - } - // end set selectivity - - INFO_LOG << "Checking for available index likelihood function." - << std::endl; - // set index likelihood - if (f->fleet_index_likelihood_id_m != -999) { - uint32_t ind_like_id = static_cast( - f->fleet_index_likelihood_id_m); // cast as unsigned integer - distribution_models_iterator it = this->distribution_models.find( - ind_like_id); // if find, set it, otherwise invalid - INFO_LOG << "Input index likelihood function id = " << ind_like_id - << "." << std::endl; - - if (it != this->distribution_models.end()) { - f->index_likelihood = - (*it).second; // elements in container held in pair (first is - // id, second is object - shared pointer to - // distribution) - INFO_LOG << "Index likelihood function successfully set." - << std::endl; - } else { - // Commented out for now as code uses single likelihood function - // making this fail valid_model = false; ERROR_LOG << "Error: Expected - // index likelihood function not defined for fleet " - // << f->id << ", likelihood function " << ind_like_id << - // std::endl; - // exit(1); + /** + * @brief Set pointers to length composition data in the fleet module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param f shared pointer to fleet module + */ + void SetLengthCompositionData( + bool &valid_model, + std::shared_ptr > f) { + if (f->fleet_observed_lengthcomp_data_id_m != -999) { + uint32_t observed_lengthcomp_id = + static_cast (f->fleet_observed_lengthcomp_data_id_m); + data_iterator it = this->data_objects.find(observed_lengthcomp_id); + if (it != this->data_objects.end()) { + f->observed_lengthcomp_data = (*it).second; + FIMS_INFO_LOG("Observed input length-composition data for fleet " + + fims::to_string(f->id) + " successfully set to " + + fims::to_string(f->observed_lengthcomp_data->at(1))); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected length-composition observations not defined for fleet " + + fims::to_string(f->id)); + } + } } - } else { - // Commented out for now as code uses single likelihood function making - // this fail valid_model = false; ERROR_LOG << "Error: No index - // likelihood function defined for fleet " << f->id - // << ". FIMS requires likelihood functions be defined for all - // data." << std::endl; - // exit(1); - } - // end set index likelihood - - INFO_LOG << "Checking for available age comp likelihood function." - << std::endl; - // set agecomp likelihood - if (f->fleet_agecomp_likelihood_id_m != -999) { - uint32_t ac_like_id = static_cast( - f->fleet_agecomp_likelihood_id_m); // cast as unsigned integer - distribution_models_iterator it = this->distribution_models.find( - ac_like_id); // if find, set it, otherwise invalid - INFO_LOG << "Input age comp likelihood function id = " << ac_like_id - << "." << std::endl; - - if (it != this->distribution_models.end()) { - f->agecomp_likelihood = - (*it).second; // elements in container held in pair (first is - // id, second is object - shared pointer to - // distribution) - INFO_LOG << "Age comp likelihood function successfully set." - << std::endl; - } else { - // Commented out for now as code uses single likelihood function - // making this fail valid_model = false; ERROR_LOG << "Error: Expected - // age comp likelihood function not defined for fleet " - // << f->id << ", likelihood function " << ac_like_id << - // std::endl; - // exit(1); + /** + * @brief Set pointers to the selectivity module referenced in the fleet module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param f shared pointer to fleet module + */ + void SetFleetSelectivityModel( + bool &valid_model, + std::shared_ptr > f) { + if (f->fleet_selectivity_id_m != -999) { + uint32_t sel_id = static_cast ( + f->fleet_selectivity_id_m); // cast as unsigned integer + selectivity_models_iterator it = this->selectivity_models.find( + sel_id); // if find, set it, otherwise invalid + + if (it != this->selectivity_models.end()) { + f->selectivity = (*it).second; // elements in container held in pair + FIMS_INFO_LOG("Selectivity model " + + fims::to_string(f->fleet_selectivity_id_m) + + " successfully set to fleet " + fims::to_string(f->id)); + + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected selectivity pattern not defined for fleet " + + fims::to_string(f->id) + ", selectivity pattern " + fims::to_string(sel_id)); + } + + } else { + valid_model = false; + FIMS_ERROR_LOG("Error: No selectivity pattern defined for fleet " + fims::to_string(f->id) + + ". FIMS requires selectivity be defined for all fleets."); + } } - } else { - // Commented out for now as code uses single likelihood function making - // this fail valid_model = false; ERROR_LOG << "Error: No age comp - // likelihood function defined for fleet " << f->id - // << ". FIMS requires likelihood functions be defined for all - // data." << std::endl; - // exit(1); - } - // end set agecomp likelihood - - INFO_LOG << "Completed initialization for fleet " << f->id << "." - << std::endl; - - } // close fleet iterator loop - INFO_LOG << "Completed initialization of all fleets." << std::endl; - - INFO_LOG << "Initializing population objects for " - << this->populations.size() << " populations." << std::endl; - for (population_iterator it = this->populations.begin(); - it != this->populations.end(); ++it) { - std::shared_ptr > p = (*it).second; - - INFO_LOG << "Setting up links from population " << p->id - << " to fleets [ " << std::flush; - // error check and set population elements - // check me - add another fleet iterator to push information from - for (fleet_iterator it = this->fleets.begin(); it != this->fleets.end(); - ++it) { - // Initialize fleet object - std::shared_ptr > f = (*it).second; - // population to the individual fleets This is to pass catch at age - // from population to fleets? - // any shared member in p (population is pushed into fleets) - p->fleets.push_back(f); - INFO_LOG << f->id << " " << std::flush; - } - INFO_LOG << "]" << std::endl; - - INFO_LOG << "Initializing population " << p->id << "." << std::endl; - p->Initialize(p->nyears, p->nseasons, p->nages); - - INFO_LOG << "Checking for available recruitment function." << std::endl; - // set recruitment - if (p->recruitment_id != -999) { - uint32_t recruitment_uint = static_cast(p->recruitment_id); - recruitment_models_iterator it = - this->recruitment_models.find(recruitment_uint); - INFO_LOG << "Input recruitment id = " << recruitment_uint << "." - << std::endl; - if (it != this->recruitment_models.end()) { - p->recruitment = - (*it).second; // recruitment defined in population.hpp - INFO_LOG << "Recruitment function successfully set." << std::endl; - } else { - valid_model = false; - ERROR_LOG << "Error: Expected recruitment function not defined for " - "population " - << p->id << ", recruitment function " << recruitment_uint - << std::endl; - exit(1); + /** + * @brief Set pointers to the recruitment module referened in the population module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param p shared pointer to population module + */ + void SetRecruitment( + bool &valid_model, + std::shared_ptr > p) { + if (p->recruitment_id != -999) { + uint32_t recruitment_uint = static_cast (p->recruitment_id); + recruitment_models_iterator it = + this->recruitment_models.find(recruitment_uint); + + if (it != this->recruitment_models.end()) { + p->recruitment = + (*it).second; // recruitment defined in population.hpp + FIMS_INFO_LOG("Recruitment model " + + fims::to_string(recruitment_uint) + + " successfully set to population " + + fims::to_string(p->id)); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected recruitment function not defined for " + "population " + + fims::to_string(p->id) + ", recruitment function " + + fims::to_string(recruitment_uint)); + } + + } else { + valid_model = false; + FIMS_ERROR_LOG("No recruitment function defined for population " + + fims::to_string(p->id) + + ". FIMS requires recruitment functions be defined for all " + "populations."); + } } - } else { - valid_model = false; - ERROR_LOG << "Error: No recruitment function defined for population " - << p->id - << ". FIMS requires recruitment functions be defined for all " - "populations." - << std::endl; - exit(1); - } - - INFO_LOG << "Checking for available growth function." << std::endl; - // set growth - if (p->growth_id != -999) { - uint32_t growth_uint = static_cast(p->growth_id); - growth_models_iterator it = this->growth_models.find( - growth_uint); // growth_models is specified in information.hpp - // and used in rcpp - // at the head of information.hpp; are the - // dimensions of ages defined in rcpp or where? - INFO_LOG << "Input growth id = " << growth_uint << "." << std::endl; - if (it != this->growth_models.end()) { - p->growth = - (*it).second; // growth defined in population.hpp (the object - // is called p, growth is within p) - INFO_LOG << "Growth function successfully set." << std::endl; - } else { - valid_model = false; - ERROR_LOG - << "Error: Expected growth function not defined for population " - << p->id << ", growth function " << growth_uint << std::endl; - exit(1); + /** + * @brief Set pointers to the growth module referened in the population module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param p shared pointer to population module + */ + void SetGrowth( + bool &valid_model, + std::shared_ptr > p) { + if (p->growth_id != -999) { + uint32_t growth_uint = static_cast (p->growth_id); + growth_models_iterator it = this->growth_models.find( + growth_uint); // growth_models is specified in information.hpp + // and used in rcpp + // at the head of information.hpp; are the + // dimensions of ages defined in rcpp or where? + if (it != this->growth_models.end()) { + p->growth = + (*it).second; // growth defined in population.hpp (the object + // is called p, growth is within p) + FIMS_INFO_LOG("Growth model " + + fims::to_string(growth_uint) + + " successfully set to population " + fims::to_string(p->id)); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected growth function not defined for population " + + fims::to_string(p->id) + ", growth function " + + fims::to_string(growth_uint)); + } + + } else { + valid_model = false; + FIMS_ERROR_LOG("No growth function defined for population " + + fims::to_string(p->id) + + ". FIMS requires growth functions be defined for all " + "populations."); + } } - } else { - valid_model = false; - ERROR_LOG << "Error: No growth function defined for population " - << p->id - << ". FIMS requires growth functions be defined for all " - "populations." - << std::endl; - exit(1); - } - - INFO_LOG << "Checking for available maturity function." << std::endl; - // set maturity - if (p->maturity_id != -999) { - uint32_t maturity_uint = static_cast(p->maturity_id); - maturity_models_iterator it = this->maturity_models.find( - maturity_uint); // >maturity_models is specified in - // information.hpp and used in rcpp - INFO_LOG << "Input maturity id = " << maturity_uint << "." << std::endl; - if (it != this->maturity_models.end()) { - p->maturity = (*it).second; // >maturity defined in population.hpp - INFO_LOG << "Maturity function successfully set." << std::endl; - } else { - valid_model = false; - ERROR_LOG - << "Error: Expected maturity function not defined for population " - << p->id << ", maturity function " << maturity_uint << std::endl; - exit(1); + /** + * @brief Set pointers to the maturity module referened in the population module. + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + * @param p shared pointer to population module + */ + void SetMaturity( + bool &valid_model, + std::shared_ptr > p) { + if (p->maturity_id != -999) { + uint32_t maturity_uint = static_cast (p->maturity_id); + maturity_models_iterator it = this->maturity_models.find( + maturity_uint); // >maturity_models is specified in + // information.hpp and used in rcpp + if (it != this->maturity_models.end()) { + p->maturity = (*it).second; // >maturity defined in population.hpp + FIMS_INFO_LOG("Maturity model " + + fims::to_string(maturity_uint) + + " successfully set to population " + fims::to_string(p->id)); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected maturity function not defined for population " + + fims::to_string(p->id) + ", maturity function " + + fims::to_string(maturity_uint)); + } + } else { + + valid_model = false; + FIMS_ERROR_LOG("No maturity function defined for population " + + fims::to_string(p->id) + + ". FIMS requires maturity functions be defined for all " + "populations."); + } } - } else { - valid_model = false; - ERROR_LOG << "Error: No maturity function defined for population " - << p->id - << ". FIMS requires maturity functions be defined for all " - "populations." - << std::endl; - exit(1); - } - INFO_LOG << "Completed initialization for population " << p->id << "." - << std::endl; - } - INFO_LOG << "Completed initialization of all populations." << std::endl; - INFO_LOG << "Completed FIMS model creation." << std::endl; - return valid_model; - } - - /** - * @brief Get the Nages object - * - * @return size_t - */ - size_t GetNages() const { return nages; } - - /** - * @brief Set the Nages object - * - * @param nages - */ - void SetNages(size_t nages) { this->nages = nages; } - - /** - * @brief Get the Nseasons object - * - * @return size_t - */ - size_t GetNseasons() const { return nseasons; } - - /** - * @brief Set the Nseasons object - * - * @param nseasons - */ - void SetNseasons(size_t nseasons) { this->nseasons = nseasons; } - - /** - * @brief Get the Nyears object - * - * @return size_t - */ - size_t GetNyears() const { return nyears; } - - /** - * @brief Set the Nyears object - * - * @param nyears - */ - void SetNyears(size_t nyears) { this->nyears = nyears; } - - /** - * @brief Get the Parameters object - * - * @return std::vector& - */ - std::vector& GetParameters() { return parameters; } - - /** - * @brief Get the Fixed Effects Parameters object - * - * @return std::vector& - */ - std::vector& GetFixedEffectsParameters() { - return fixed_effects_parameters; - } - - /** - * @brief Get the Random Effects Parameters object - * - * @return std::vector& - */ - std::vector& GetRandomEffectsParameters() { - return random_effects_parameters; - } -}; - -template -std::shared_ptr > Information::fims_information = - nullptr; // singleton instance - -} // namespace fims_info + /** + * @brief Loop over all fleets and set pointers to fleet objects + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + */ + void CreateFleetObjects(bool &valid_model) { + for (fleet_iterator it = this->fleets.begin(); it != this->fleets.end(); + ++it) { + + std::shared_ptr > f = (*it).second; + FIMS_INFO_LOG("Initializing fleet " + fims::to_string(f->id)); + + f->Initialize(f->nyears, f->nages, f->nlengths); + + SetFleetIndexData(valid_model, f); + + SetAgeCompositionData(valid_model, f); + + SetLengthCompositionData(valid_model, f); + + SetFleetSelectivityModel(valid_model, f); + } + } + + /** + * @brief Loop over all density components and set pointers to data objects + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + */ + void SetDataObjects(bool &valid_model) { + for (density_components_iterator it = this->density_components.begin(); + it != this->density_components.end(); ++it) { + std::shared_ptr > d = (*it).second; + + //set data objects if distribution is a data type + if (d->input_type == "data") { + if (d->observed_data_id_m != -999) { + uint32_t observed_data_id = static_cast (d->observed_data_id_m); + data_iterator it = this->data_objects.find(observed_data_id); + + if (it != this->data_objects.end()) { + d->observed_values = (*it).second; + FIMS_INFO_LOG("Observed data " + + fims::to_string(observed_data_id) + + " successfully set to density component " + fims::to_string(d->id)); + } else { + valid_model = false; + FIMS_ERROR_LOG("Expected data observations not defined for density component " + + fims::to_string(d->id) + ", observed data " + fims::to_string(observed_data_id)); + } + + } else { + valid_model = false; + FIMS_ERROR_LOG("No data input for density component" + fims::to_string(d->id)); + } + } + } + + } + + /** + * @brief Loop over all populations and set pointers to population objects + * + * @param &valid_model reference to true/false boolean indicating whether model is valid. + */ + void CreatePopulationObjects(bool &valid_model) { + for (population_iterator it = this->populations.begin(); + it != this->populations.end(); ++it) { + std::shared_ptr > p = (*it).second; + + FIMS_INFO_LOG("Initializing population " + fims::to_string(p->id)); + // error check and set population elements + // check me - add another fleet iterator to push information from + for (fleet_iterator it = this->fleets.begin(); it != this->fleets.end(); + ++it) { + // Initialize fleet object + std::shared_ptr > f = (*it).second; + // population to the individual fleets This is to pass catch at age + // from population to fleets? + // any shared member in p (population is pushed into fleets) + p->fleets.push_back(f); + } + + p->Initialize(p->nyears, p->nseasons, p->nages); + + //set information dimensions + this->nyears = std::max(this->nyears, p->nyears); + this->nages = std::max(this->nages, p->nages); + this->nseasons = std::max(this->nseasons, p->nseasons); + + SetRecruitment(valid_model, p); + + SetGrowth(valid_model, p); + + SetMaturity(valid_model, p); + + } + } + + /** + * @brief Create the generalized stock assessment model that will evaluate the + * objective function. Does error checking to make sure the program has + * all necessary components for the model and that they're in the right + * dimensions. This sets up pointers to all memory objects and initializes + * fleet and population objects. + * + * @return True if valid model, False if invalid model, check fims.log for + * errors. + */ + bool CreateModel() { + bool valid_model = true; + + CreateFleetObjects(valid_model); + + SetDataObjects(valid_model); + + CreatePopulationObjects(valid_model); + + //setup priors, random effect, and data density components + SetupPriors(); + + return valid_model; + } + + /** + * @brief Get the Nages object + * + * @return size_t + */ + size_t GetNages() const { + + return nages; + } + + /** + * @brief Set the Nages object + * + * @param nages + */ + void SetNages(size_t nages) { + + this->nages = nages; + } + + /** + * @brief Get the Nseasons object + * + * @return size_t + */ + size_t GetNseasons() const { + + return nseasons; + } + + /** + * @brief Set the Nseasons object + * + * @param nseasons + */ + void SetNseasons(size_t nseasons) { + + this->nseasons = nseasons; + } + + /** + * @brief Get the Nyears object + * + * @return size_t + */ + size_t GetNyears() const { + + return nyears; + } + + /** + * @brief Set the Nyears object + * + * @param nyears + */ + void SetNyears(size_t nyears) { + + this->nyears = nyears; + } + + /** + * @brief Get the Parameters object + * + * @return std::vector& + */ + std::vector& GetParameters() { + + return parameters; + } + + /** + * @brief Get the Fixed Effects Parameters object + * + * @return std::vector& + */ + std::vector& GetFixedEffectsParameters() { + + return fixed_effects_parameters; + } + + /** + * @brief Get the Random Effects Parameters object + * + * @return std::vector& + */ + std::vector& GetRandomEffectsParameters() { + return random_effects_parameters; + } + }; + + template + std::shared_ptr > Information::fims_information = + nullptr; // singleton instance + +} // namespace fims_info #endif /* FIMS_COMMON_INFORMATION_HPP */ diff --git a/inst/include/common/mainpage.dox b/inst/include/common/mainpage.dox new file mode 100644 index 000000000..e65235cdb --- /dev/null +++ b/inst/include/common/mainpage.dox @@ -0,0 +1,13 @@ +/** + * @file mainpage.dox + * @mainpage C++ source code documentation + * + * This site contains C++ source code documentation for the Fisheries + * Integrated Modeling System (FIMS). Other forms of documentation are linked + * from the main documentation site at + * https://noaa-fims.github.io/FIMS/articles/fims-documentation.html. + * + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ \ No newline at end of file diff --git a/inst/include/common/model.hpp b/inst/include/common/model.hpp index 402eebe33..5aa5bf2c0 100644 --- a/inst/include/common/model.hpp +++ b/inst/include/common/model.hpp @@ -1,17 +1,9 @@ -/* - * File: model.hpp - * - * Author: Matthew Supernaw, Andrea Havron - * National Oceanic and Atmospheric Administration - * National Marine Fisheries Service - * Email: matthew.supernaw@noaa.gov, andrea.havron@noaa.gov - * - * Created on September 30, 2021, 1:08 PM - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * +/** + * @file model.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_COMMON_MODEL_HPP #define FIMS_COMMON_MODEL_HPP @@ -23,204 +15,273 @@ namespace fims_model { -/** - * @brief Model class. FIMS objective function. - */ -template -class Model { // may need singleton - public: - static std::shared_ptr > - fims_model; /**< Create a shared fims_model as a pointer to Model*/ - std::shared_ptr > - fims_information; /**< Create a shared fims_information as a pointer to + /** + * @brief Model class. FIMS objective function. + */ + template + class Model { // may need singleton + public: + static std::shared_ptr > + fims_model; /**< Create a shared fims_model as a pointer to Model*/ + std::shared_ptr > + fims_information; /**< Create a shared fims_information as a pointer to Information*/ #ifdef TMB_MODEL - ::objective_function *of; + ::objective_function *of; #endif - // constructor - virtual ~Model() {} - - /** - * Returns a single Information object for type Type. - * - * @return singleton for type Type - */ - static std::shared_ptr > GetInstance() { - if (Model::fims_model == nullptr) { - Model::fims_model = std::make_shared >(); - Model::fims_model->fims_information = - fims_info::Information::GetInstance(); - } - return Model::fims_model; - } - - /** - * @brief Evaluate. Calculates the joint negative log-likelihood function. - */ - const Type Evaluate() { - // jnll = negative-log-likelihood (the objective function) - Type jnll = 0.0; - Type rec_nll = 0.0; // recrutiment nll - Type age_comp_nll = 0.0; // age composition nll - Type index_nll = 0.0; // survey and fishery cacth nll - - int n_fleets = fims_information->fleets.size(); - int n_pops = fims_information->populations.size(); - -// Create vector lists to store output for reporting + // constructor + + virtual ~Model() { + } + + /** + * Returns a single Information object for type Type. + * + * @return singleton for type Type + */ + static std::shared_ptr > GetInstance() { + if (Model::fims_model == nullptr) { + Model::fims_model = std::make_shared >(); + Model::fims_model->fims_information = + fims_info::Information::GetInstance(); + } + return Model::fims_model; + } + + /** + * @brief Evaluate. Calculates the joint negative log-likelihood function. + */ + const Type Evaluate() { + // jnll = negative-log-likelihood (the objective function) + Type jnll = 0.0; + + + int n_fleets = fims_information->fleets.size(); + int n_pops = fims_information->populations.size(); + + // Create vector lists to store output for reporting #ifdef TMB_MODEL - // vector< vector > creates a nested vector structure where - // each vector can be a different dimension. Does not work with ADREPORT - // fleets - vector > exp_index(n_fleets); - vector > exp_catch(n_fleets); - vector > cnaa(n_fleets); - vector > cwaa(n_fleets); - vector > F_mort(n_fleets); - // populations - vector > naa(n_pops); - vector > ssb(n_pops); - vector > biomass(n_pops); - vector > log_recruit_dev(n_pops); - vector > recruitment(n_pops); - vector > M(n_pops); + // vector< vector > creates a nested vector structure where + // each vector can be a different dimension. Does not work with ADREPORT + // fleets + vector > exp_index(n_fleets); + vector > exp_catch(n_fleets); + vector > cnaa(n_fleets); + vector > cwaa(n_fleets); + vector > cnal(n_fleets); + vector > pcnaa(n_fleets); + vector > pcnal(n_fleets); + vector > F_mort(n_fleets); + vector > q(n_fleets); + // populations + vector > naa(n_pops); + vector > ssb(n_pops); + vector > biomass(n_pops); + vector > log_recruit_dev(n_pops); + vector > recruitment(n_pops); + vector > M(n_pops); + vector nll_components(this->fims_information->density_components.size()); +#endif + // Loop over densities and evaluate joint negative log densities for priors + typename fims_info::Information::density_components_iterator d_it; + nll_components.fill(0); + int nll_components_idx = 0; + size_t n_priors = 0; + for (d_it = this->fims_information->density_components.begin(); + d_it != this->fims_information->density_components.end(); ++d_it) { + std::shared_ptr > d = (*d_it).second; +#ifdef TMB_MODEL + d->of = this->of; #endif + if (d->input_type == "prior") { + nll_components[nll_components_idx] = -d->evaluate(); + jnll += nll_components[nll_components_idx]; + n_priors += 1; + nll_components_idx += 1; + } + } + + + + // Loop over populations and evaluate recruitment component + + typename fims_info::Information::population_iterator p_it; - // Loop over populations, evaluate, and sum up the recruitment likelihood - // component - - typename fims_info::Information::population_iterator it; - MODEL_LOG << "Evaluating expected values and summing recruitment nlls for " - << this->fims_information->populations.size() << " populations." - << std::endl; - - for (it = this->fims_information->populations.begin(); - it != this->fims_information->populations.end(); ++it) { - //(*it).second points to the Population module - MODEL_LOG << "Setting up pointer to population " << (*it).second->id - << "." << std::endl; - // Prepare recruitment - (*it).second->recruitment->Prepare(); - MODEL_LOG << "Recruitment for population successfully prepared" - << std::endl; -// link to TMB objective function + + for (p_it = this->fims_information->populations.begin(); + p_it != this->fims_information->populations.end(); ++p_it) { + //(*p_it).second points to the Population module + std::shared_ptr > p = (*p_it).second; + + // Prepare recruitment + p->recruitment->Prepare(); + + } + + // Loop over densities and evaluate joint negative log-likelihoods for random effects + this->fims_information->SetupRandomEffects(); + size_t n_random_effects = 0; + for (d_it = this->fims_information->density_components.begin(); + d_it != this->fims_information->density_components.end(); ++d_it) { + std::shared_ptr > d = (*d_it).second; #ifdef TMB_MODEL - (*it).second->of = this->of; + d->of = this->of; #endif - // Evaluate population - (*it).second->Evaluate(); - // Recrtuiment negative log-likelihood - rec_nll += (*it).second->recruitment->evaluate_nll(); - MODEL_LOG << "Recruitment negative log-likelihood is: " << rec_nll - << std::endl; - } - MODEL_LOG << "All populations successfully evaluated." << std::endl; - - // Loop over fleets/surveys, and sum up age comp and index nlls - - typename fims_info::Information::fleet_iterator jt; - MODEL_LOG << "Evaluating expected values and summing nlls for " - << this->fims_information->fleets.size() << " fleets." - << std::endl; - - for (jt = this->fims_information->fleets.begin(); - jt != this->fims_information->fleets.end(); ++jt) { - //(*jt).second points to each individual Fleet module + if (d->input_type == "random_effects") { + nll_components[nll_components_idx] = -d->evaluate(); + jnll += nll_components[nll_components_idx]; + n_random_effects += 1; + nll_components_idx += 1; + } + } + + + // Loop over and evaluate populations + for (p_it = this->fims_information->populations.begin(); + p_it != this->fims_information->populations.end(); ++p_it) { + //(*p_it).second points to the Population module + std::shared_ptr > p = (*p_it).second; + // link to TMB objective function #ifdef TMB_MODEL - (*jt).second->of = this->of; + p->of = this->of; #endif - MODEL_LOG << "Setting up pointer to fleet " << (*jt).second->id << "." - << std::endl; - age_comp_nll += (*jt).second->evaluate_age_comp_nll(); - MODEL_LOG << "Sum of survey and age comp negative log-likelihood is: " - << age_comp_nll << std::endl; - index_nll += (*jt).second->evaluate_index_nll(); - } - MODEL_LOG << "All fleets successfully evaluated." << std::endl; - // Loop over populations and fleets/surveys and fill in reporting - - // initiate population index for structuring report out objects - int pop_idx = 0; - for (it = this->fims_information->populations.begin(); - it != this->fims_information->populations.end(); ++it) { + // Evaluate population + p->Evaluate(); + } + + typename fims_info::Information::fleet_iterator f_it; + // Loop over fleets/surveys, and evaluate age comp and index expected values + for (f_it = this->fims_information->fleets.begin(); + f_it != this->fims_information->fleets.end(); ++f_it) { + //(*f_it).second points to each individual Fleet module + std::shared_ptr > f = (*f_it).second; #ifdef TMB_MODEL - naa(pop_idx) = vector((*it).second->numbers_at_age); - ssb(pop_idx) = vector((*it).second->spawning_biomass); - log_recruit_dev(pop_idx) = - vector((*it).second->recruitment->log_recruit_devs); - recruitment(pop_idx) = vector((*it).second->expected_recruitment); - biomass(pop_idx) = vector((*it).second->biomass); - M(pop_idx) = vector((*it).second->M); + f->of = this->of; #endif - pop_idx += 1; - } - // initiate fleet index for structuring report out objects - int fleet_idx = 0; - for (jt = this->fims_information->fleets.begin(); - jt != this->fims_information->fleets.end(); ++jt) { + f->evaluate_age_comp(); + if (f->nlengths > 0) { + f->evaluate_length_comp(); + } + f->evaluate_index(); + } + this->fims_information->SetupData(); + // Loop over and evaluate data joint negative log-likelihoods + int n_data = 0; + for (d_it = this->fims_information->density_components.begin(); + d_it != this->fims_information->density_components.end(); ++d_it) { + std::shared_ptr > d = (*d_it).second; #ifdef TMB_MODEL - exp_index(fleet_idx) = (*jt).second->expected_index; - exp_catch(fleet_idx) = (*jt).second->expected_catch; - F_mort(fleet_idx) = (*jt).second->Fmort; - cnaa(fleet_idx) = (*jt).second->catch_numbers_at_age; - cwaa(fleet_idx) = (*jt).second->catch_weight_at_age; + d->of = this->of; + //d->keep = this->keep; #endif - fleet_idx += 1; - } + if (d->input_type == "data") { + nll_components[nll_components_idx] = -d->evaluate(); + jnll += nll_components[nll_components_idx]; + n_data += 1; + nll_components_idx += 1; + } + } - jnll = rec_nll + age_comp_nll + index_nll; + // initiate population index for structuring report out objects + int pop_idx = 0; + for (p_it = this->fims_information->populations.begin(); + p_it != this->fims_information->populations.end(); ++p_it) { + std::shared_ptr > p = (*p_it).second; +#ifdef TMB_MODEL + naa(pop_idx) = vector(p->numbers_at_age); + ssb(pop_idx) = vector(p->spawning_biomass); + log_recruit_dev(pop_idx) = + vector(p->recruitment->log_recruit_devs); + recruitment(pop_idx) = vector(p->expected_recruitment); + biomass(pop_idx) = vector(p->biomass); + M(pop_idx) = vector(p->M); +#endif + pop_idx += 1; + } -// Reporting + // initiate fleet index for structuring report out objects + int fleet_idx = 0; + for (f_it = this->fims_information->fleets.begin(); + f_it != this->fims_information->fleets.end(); ++f_it) { + std::shared_ptr > f = (*f_it).second; #ifdef TMB_MODEL - REPORT_F(rec_nll, of); - REPORT_F(age_comp_nll, of); - REPORT_F(index_nll, of); - REPORT_F(jnll, of); - REPORT_F(naa, of); - REPORT_F(ssb, of); - REPORT_F(log_recruit_dev, of); - REPORT_F(recruitment, of); - REPORT_F(biomass, of); - REPORT_F(M, of); - REPORT_F(exp_index, of); - REPORT_F(exp_catch, of); - REPORT_F(F_mort, of); - REPORT_F(cnaa, of); - REPORT_F(cwaa, of); - - /*ADREPORT using ADREPORTvector defined in - * inst/include/interface/interface.hpp: - * function collapses the nested vector into a single vector - */ - vector NAA = ADREPORTvector(naa); - vector Biomass = ADREPORTvector(biomass); - vector SSB = ADREPORTvector(ssb); - vector LogRecDev = ADREPORTvector(log_recruit_dev); - vector FMort = ADREPORTvector(F_mort); - vector ExpectedIndex = ADREPORTvector(exp_index); - vector CNAA = ADREPORTvector(cnaa); - - ADREPORT_F(NAA, of); - ADREPORT_F(Biomass, of); - ADREPORT_F(SSB, of); - ADREPORT_F(LogRecDev, of); - ADREPORT_F(FMort, of); - ADREPORT_F(ExpectedIndex, of); - ADREPORT_F(CNAA, of); + exp_index(fleet_idx) = f->expected_index; + exp_catch(fleet_idx) = f->expected_catch; + F_mort(fleet_idx) = f->Fmort; + q(fleet_idx) = f->q; + cnaa(fleet_idx) = f->catch_numbers_at_age; + cnal(fleet_idx) = f->catch_numbers_at_length; + pcnaa(fleet_idx) = f->proportion_catch_numbers_at_age; + pcnal(fleet_idx) = f->proportion_catch_numbers_at_length; + cwaa(fleet_idx) = f->catch_weight_at_age; +#endif + fleet_idx += 1; + } + + // Reporting +#ifdef TMB_MODEL + //FIMS_REPORT_F(rec_nll, of); + //FIMS_REPORT_F(age_comp_nll, of); + //FIMS_REPORT_F(index_nll, of); + FIMS_REPORT_F(jnll, of); + FIMS_REPORT_F(naa, of); + FIMS_REPORT_F(ssb, of); + FIMS_REPORT_F(log_recruit_dev, of); + FIMS_REPORT_F(recruitment, of); + FIMS_REPORT_F(biomass, of); + FIMS_REPORT_F(M, of); + FIMS_REPORT_F(exp_index, of); + FIMS_REPORT_F(exp_catch, of); + FIMS_REPORT_F(F_mort, of); + FIMS_REPORT_F(q, of); + FIMS_REPORT_F(cnaa, of); + FIMS_REPORT_F(cnal, of); + FIMS_REPORT_F(pcnaa, of); + FIMS_REPORT_F(pcnal, of); + FIMS_REPORT_F(cwaa, of); + FIMS_REPORT_F(nll_components, of); + + /*ADREPORT using ADREPORTvector defined in + * inst/include/interface/interface.hpp: + * function collapses the nested vector into a single vector + */ + vector NAA = ADREPORTvector(naa); + vector Biomass = ADREPORTvector(biomass); + vector SSB = ADREPORTvector(ssb); + vector LogRecDev = ADREPORTvector(log_recruit_dev); + vector FMort = ADREPORTvector(F_mort); + vector Q = ADREPORTvector(q); + vector ExpectedIndex = ADREPORTvector(exp_index); + vector CNAA = ADREPORTvector(cnaa); + vector CNAL = ADREPORTvector(cnal); + vector PCNAA = ADREPORTvector(pcnaa); + vector PCNAL = ADREPORTvector(pcnal); + + ADREPORT_F(NAA, of); + ADREPORT_F(Biomass, of); + ADREPORT_F(SSB, of); + ADREPORT_F(LogRecDev, of); + ADREPORT_F(FMort, of); + ADREPORT_F(Q, of); + ADREPORT_F(ExpectedIndex, of); + ADREPORT_F(CNAA, of); + ADREPORT_F(CNAL, of); + ADREPORT_F(PCNAA, of); + ADREPORT_F(PCNAL, of); #endif - return jnll; - } -}; + return jnll; + } + }; -// Create singleton instance of Model class -template -std::shared_ptr > Model::fims_model = - nullptr; // singleton instance -} // namespace fims_model + // Create singleton instance of Model class + template + std::shared_ptr > Model::fims_model = + nullptr; // singleton instance +} // namespace fims_model #endif /* FIMS_COMMON_MODEL_HPP */ diff --git a/inst/include/common/model_object.hpp b/inst/include/common/model_object.hpp index 28ef1e7c8..56b21d55a 100644 --- a/inst/include/common/model_object.hpp +++ b/inst/include/common/model_object.hpp @@ -1,10 +1,9 @@ -/* - * File: model_object.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * +/** + * @file model_object.hpp + * @brief TODO: provide a brief description. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_COMMON_MODEL_OBJECT_HPP @@ -18,25 +17,46 @@ namespace fims_model_object { -/** - * @brief FIMSObject struct that defines member types and returns the unique id - */ -template -struct FIMSObject { - uint32_t id; /**< unique identifier assigned for all fims objects */ - std::vector parameters; /**< list of estimable parameters */ - std::vector - random_effects_parameters; /**< list of all random effects parameters */ - std::vector - fixed_effects_parameters; /**< list of fixed effects parameters */ - - virtual ~FIMSObject() {} - /** - * @brief Getter that returns the unique id for parameters in the model - */ - uint32_t GetId() const { return id; } -}; - -} // namespace fims_model_object + /** + * @brief FIMSObject struct that defines member types and returns the unique id + */ + template + struct FIMSObject { + uint32_t id; /**< unique identifier assigned for all fims objects */ + std::vector parameters; /**< list of estimable parameters */ + std::vector + random_effects_parameters; /**< list of all random effects parameters */ + std::vector + fixed_effects_parameters; /**< list of fixed effects parameters */ + + virtual ~FIMSObject() { + } + + /** + * @brief Getter that returns the unique id for parameters in the model + */ + uint32_t GetId() const { + return id; + } + + /** + * @brief Check the dimensions of an object + * + * @param actual The actual dimensions. + * @param expected The expected dimensions. + * @return true + * @return false + */ + inline bool CheckDimensions(size_t actual, size_t expected) { + if (actual != expected) { + return false; + } + + return true; + } + + }; + +} // namespace fims_model_object #endif /* FIMS_COMMON_MODEL_OBJECT_HPP */ diff --git a/inst/include/distributions/distributions.hpp b/inst/include/distributions/distributions.hpp index f28c7a3f4..dcd12f85d 100644 --- a/inst/include/distributions/distributions.hpp +++ b/inst/include/distributions/distributions.hpp @@ -1,20 +1,19 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Distributions module file - * The purpose of this file is to include any .hpp files within the +/** + * @file distributions.hpp + * @brief This distributions module includes any .hpp files within the * subfolders so that only this file needs to included in the model.hpp file. - * - * DEFINE guards for distributions module outline to define the + * @details Defines guards for distributions module outline to define the * distributions hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_DISTRIBUTIONS_HPP #define FIMS_DISTRIBUTIONS_HPP -#include "functors/distributions_base.hpp" -#include "functors/tmb_distributions.hpp" +#include "functors/density_components_base.hpp" +#include "functors/lognormal_lpdf.hpp" +#include "functors/multinomial_lpmf.hpp" +#include "functors/normal_lpdf.hpp" #endif /* FIMS_DISTRIBUTIONS_HPP */ diff --git a/inst/include/distributions/functors/density_components_base.hpp b/inst/include/distributions/functors/density_components_base.hpp new file mode 100644 index 000000000..d0c271002 --- /dev/null +++ b/inst/include/distributions/functors/density_components_base.hpp @@ -0,0 +1,69 @@ + +/** + * @file density_components_base.hpp + * @brief Declares the DensityComponentBase class, which is the base class for + * all distribution functors. + * @details Defines guards for distributions module outline to define the + * density_components_base hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ +#ifndef DENSITY_COMPONENT_BASE_HPP +#define DENSITY_COMPONENT_BASE_HPP + +#include "../../common/data_object.hpp" +#include "../../common/model_object.hpp" +#include "../../interface/interface.hpp" +#include "../../common/fims_vector.hpp" +#include "../../common/fims_math.hpp" + +namespace fims_distributions { + +/** @brief Base class for all module_name functors. + * + * @tparam Type The type of the module_name functor. + * + */ +template +struct DensityComponentBase : public fims_model_object::FIMSObject { + // id_g is the ID of the instance of the DensityComponentBase class. + // this is like a memory tracker. + // Assigning each one its own ID is a way to keep track of + // all the instances of the DensityComponentBase class. + static uint32_t id_g; /**< global unique identifier for distribution modules */ + int observed_data_id_m = -999; /*!< id of observed data component*/ + std::shared_ptr> + observed_values; /**< observed data*/ + fims::Vector x; /**< input value of distribution function for priors or random effects*/ + fims::Vector expected_values; /**< expected value of distribution function */ + fims::Vector lpdf_vec; /**< vector to record observation level negative log-likelihood values */ + std::string input_type; /**< string classifies the type of the negative log-likelihood; options are: "priors", "random_effects", and "data" */ + bool osa_flag = false; /**< Boolean; if true, osa residuals are calculated */ + bool simulate_flag = false; /**< Boolean; if true, data are simulated from the distribution */ + std::vector key; /**< unique id for variable map that points to a fims::Vector */ + + #ifdef TMB_MODEL + ::objective_function *of; /**< Pointer to the TMB objective function */ + #endif + + /** @brief Constructor. + */ + DensityComponentBase() { this->id = DensityComponentBase::id_g++; } + + virtual ~DensityComponentBase() {} + /** + * @brief Generic probability density function. Calculates the pdf at the + * independent variable value. + */ + virtual const Type evaluate() = 0; +}; + +/** @brief Default id of the singleton distribution class + */ +template +uint32_t DensityComponentBase::id_g = 0; + +} // namespace fims_distributions + +#endif /* DENSITY_COMPONENT_BASE_HPP */ diff --git a/inst/include/distributions/functors/distributions_base.hpp b/inst/include/distributions/functors/distributions_base.hpp deleted file mode 100644 index 5a50d05db..000000000 --- a/inst/include/distributions/functors/distributions_base.hpp +++ /dev/null @@ -1,55 +0,0 @@ -/** \file distributions_base.hpp - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * - * distributions_base file - * The purpose of this file is to declare the DistributionsBase class - * which is the base class for all distribution functors. - * - * DEFINE guards for distributions module outline to define the - * distributions_base hpp file if not already defined. - */ -#ifndef DISTRIBUTIONS_BASE_HPP -#define DISTRIBUTIONS_BASE_HPP - -#include "../../common/model_object.hpp" -#include "../../interface/interface.hpp" - -namespace fims_distributions { - -/** @brief Base class for all module_name functors. - * - * @tparam Type The type of the module_name functor. - * - */ -template -struct DistributionsBase : public fims_model_object::FIMSObject { - // id_g is the ID of the instance of the DistributionsBase class. - // this is like a memory tracker. - // Assigning each one its own ID is a way to keep track of - // all the instances of the DistributionsBase class. - static uint32_t id_g; - - /** @brief Constructor. - */ - DistributionsBase() { this->id = DistributionsBase::id_g++; } - - virtual ~DistributionsBase() {} - /** - * @brief Generic probability density function. Calculates the pdf at the - * independent variable value. - * @param do_log Boolean; if true, log densities are returned - */ - virtual const Type evaluate(const bool& do_log) = 0; -}; - -/** @brief Default id of the singleton distribution class - */ -template -uint32_t DistributionsBase::id_g = 0; - -} // namespace fims_distributions - -#endif /* DISTRIBUTIONS_BASE_HPP */ diff --git a/inst/include/distributions/functors/lognormal_lpdf.hpp b/inst/include/distributions/functors/lognormal_lpdf.hpp new file mode 100644 index 000000000..aa99c9ab7 --- /dev/null +++ b/inst/include/distributions/functors/lognormal_lpdf.hpp @@ -0,0 +1,100 @@ +/** + * @file lognormal_lpdf.hpp + * @brief Lognormal Log Probability Density Function (LPDF) defines the + * Lognormal LPDF class and its fields and returns the log probability density + * function. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ +#ifndef LOGNORMAL_LPDF +#define LOGNORMAL_LPDF + +#include "density_components_base.hpp" +#include "../../common/fims_vector.hpp" +#include "../../common/def.hpp" + +namespace fims_distributions +{ + /** + * LogNormal Log Probability Density Function + */ + template + struct LogNormalLPDF : public DensityComponentBase + { + fims::Vector log_sd; /**< natural log of the standard deviation of the distribution on the log scale; can be a vector or scalar */ + Type lpdf = 0.0; /**< total log probability density contribution of the distribution */ + // data_indicator , Type> keep; /**< Indicator used in TMB one-step-ahead residual calculations */ + + /** @brief Constructor. + */ + LogNormalLPDF() : DensityComponentBase() + { + } + + /** @brief Destructor. + */ + virtual ~LogNormalLPDF() {} + + /** + * @brief Evaluates the lognormal probability density function + */ + virtual const Type evaluate() + { + // set vector size based on input type (prior, process, or data) + size_t n_x; + if(this->input_type == "data"){ + n_x = this->observed_values->data.size(); + } else { + n_x = this->x.size(); + } + // setup vector for recording the log probability density function values + this->lpdf_vec.resize(n_x); + std::fill(this->lpdf_vec.begin(), this->lpdf_vec.end(), 0); + lpdf = 0; + + for (size_t i = 0; i < n_x; i++) + { + #ifdef TMB_MODEL + if(this->input_type == "data"){ + // if data, check if there are any NA values and skip lpdf calculation if there are + // See Deroba and Miller, 2016 (https://doi.org/10.1016/j.fishres.2015.12.002) for + // the use of lognormal constant + if(this->observed_values->at(i) != this->observed_values->na_value){ + this->lpdf_vec[i] = dnorm(log(this->observed_values->at(i)), this->expected_values.get_force_scalar(i), + fims_math::exp(log_sd.get_force_scalar(i)), true) - log(this->observed_values->at(i)); + } else { + this->lpdf_vec[i] = 0; + } + // if not data (i.e. prior or process), use x vector instead of observed_values and no lognormal constant needs to be applied + } else { + this->lpdf_vec[i] = dnorm(log(this->x[i]), this->expected_values.get_force_scalar(i), + fims_math::exp(log_sd.get_force_scalar(i)), true); + } + + lpdf += this->lpdf_vec[i]; + if (this->simulate_flag) + { + FIMS_SIMULATE_F(this->of) + { // preprocessor definition in interface.hpp + // this simulates data that is mean biased + if(this->input_type == "data"){ + this->observed_values->at(i) = fims_math::exp(rnorm(this->expected_values.get_force_scalar(i), + fims_math::exp(log_sd.get_force_scalar(i)))); + } else { + this->x[i] = fims_math::exp(rnorm(this->expected_values.get_force_scalar(i), + fims_math::exp(log_sd.get_force_scalar(i)))); + } + } + } + #endif + } + #ifdef TMB_MODEL + vector lognormal_x = this->x; + // FIMS_REPORT_F(lognormal_x, this->of); + #endif + return (lpdf); + } + }; +} // namespace fims_distributions +#endif diff --git a/inst/include/distributions/functors/multinomial_lpmf.hpp b/inst/include/distributions/functors/multinomial_lpmf.hpp new file mode 100644 index 000000000..4c6f9137d --- /dev/null +++ b/inst/include/distributions/functors/multinomial_lpmf.hpp @@ -0,0 +1,126 @@ +/** + * @file multinomial_lpmf.hpp + * @brief Multinomial Log Probability Mass Function (LPMF) module file defines + * the Multinomial LPMF class and its fields and returns the log probability + * mass function. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ +#ifndef MULTINOMIAL_LPMF +#define MULTINOMIAL_LPMF + +#include "density_components_base.hpp" +#include "../../common/fims_vector.hpp" +#include "../../common/def.hpp" + +namespace fims_distributions +{ + /** + * Multinomial Log Probability Mass Function + */ + template + struct MultinomialLPMF : public DensityComponentBase + { + Type lpdf = 0.0; /**< total negative log-likelihood contribution of the distribution */ + fims::Vector dims; /**< Dimensions of the number of rows and columns of the multivariate dataset */ + + /** @brief Constructor. + */ + MultinomialLPMF() : DensityComponentBase() + { + } + + /** @brief Destructor. + */ + virtual ~MultinomialLPMF() {} + + /** + * @brief Evaluates the multinomial probability mass function + */ + virtual const Type evaluate() + { + // set dims using observed_values if no user input + if(dims.size() != 2){ + dims.resize(2); + dims[0] = this->observed_values->get_imax(); + dims[1] = this->observed_values->get_jmax(); + } + + + // setup vector for recording the log probability density function values + Type lpdf = 0.0; /**< total log probability mass contribution of the distribution */ + this->lpdf_vec.resize(dims[0]); + std::fill(this->lpdf_vec.begin(), this->lpdf_vec.end(), 0); + + if (dims[0]*dims[1] != this->expected_values.size()) { + FIMS_ERROR_LOG("Observed age comp is of size " + fims::to_string(dims[0]*dims[1]) + + " and expected is of size " + fims::to_string(this->expected_values.size())); + } else { + for (size_t i = 0; i < dims[0]; i++) + { + // for each row, create new x and prob vectors + fims::Vector x_vector; + fims::Vector prob_vector; + x_vector.resize(dims[1]); + prob_vector.resize(dims[1]); + + bool containsNA = + false; /**< skips the entire row if any values are NA */ + + #ifdef TMB_MODEL + for (size_t j = 0; j < dims[1]; j++){ + if(this->input_type == "data"){ + // if data, check if there are any NA values and skip lpdf calculation for entire row if there are + if (this->observed_values->at(i, j) == + this->observed_values->na_value) { + containsNA = true; + break; + } + if(!containsNA){ + size_t idx = (i * dims[1]) + j; + x_vector[j] = this->observed_values->at(i, j); + prob_vector[j] = this->expected_values[idx]; + } + } else { + // if not data (i.e. prior or process), use x vector instead of observed_values + size_t idx = (i * dims[1]) + j; + x_vector[j] = this->x[idx]; + prob_vector[j] = this->expected_values[idx]; + } + } + + if(!containsNA){ + this->lpdf_vec[i] = dmultinom((vector)x_vector, (vector) prob_vector, true); + } else { + this->lpdf_vec[i] = 0; + } + lpdf += this->lpdf_vec[i]; + /* + if (this->simulate_flag) + { + FIMS_SIMULATE_F(this->of) + { + fims::Vector sim_observed; + sim_observed.resize(dims[1]); + sim_observed = rmultinom(prob_vector); + sim_observed.resize(this->x); + for (size_t j = 0; j < dims[1]; j++) + { + idx = (i * dims[1]) + j; + this->x[idx] = sim_observed[j]; + } + } + } + */ + #endif + } + } + #ifdef TMB_MODEL + #endif + return (lpdf); + } + +}; +} // namespace fims_distributions +#endif diff --git a/inst/include/distributions/functors/normal_lpdf.hpp b/inst/include/distributions/functors/normal_lpdf.hpp new file mode 100644 index 000000000..d85cfc77c --- /dev/null +++ b/inst/include/distributions/functors/normal_lpdf.hpp @@ -0,0 +1,94 @@ +/** + * @file normal_lpdf.hpp + * @brief Normal Log Probability Density Function (LPDF) module file defines + * the Normal LPDF class and its fields and returns the log probability density + * function. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ + +#ifndef NORMAL_LPDF +#define NORMAL_LPDF + +#include "density_components_base.hpp" +#include "../../common/fims_vector.hpp" +#include "../../common/def.hpp" + +namespace fims_distributions { +/** + * Normal Log Probability Density Function + */ +template +struct NormalLPDF : public DensityComponentBase { + fims::Vector log_sd; /**< the natural log of the standard deviation of the distribution; can be a vector or scalar */ + Type lpdf = 0.0; /**< total log probability density contribution of the distribution */ + + /** @brief Constructor. + */ + NormalLPDF() : DensityComponentBase() { + + } + + /** @brief Destructor. + */ + virtual ~NormalLPDF() {} + + /** + * @brief Evaluates the normal probability density function + */ + virtual const Type evaluate(){ + // set vector size based on input type (prior, process, or data) + size_t n_x; + if(this->input_type == "data"){ + n_x = this->observed_values->data.size(); + } else { + n_x = this->x.size(); + } + // setup vector for recording the log probability density function values + this->lpdf_vec.resize(n_x); + std::fill(this->lpdf_vec.begin(), this->lpdf_vec.end(), 0); + lpdf = 0; + + for(size_t i=0; iinput_type == "data"){ + // if data, check if there are any NA values and skip lpdf calculation if there are + if(this->observed_values->at(i) != this->observed_values->na_value){ + this->lpdf_vec[i] = dnorm(this->observed_values->at(i), this->expected_values.get_force_scalar(i), fims_math::exp(log_sd.get_force_scalar(i)), true); + } else { + this->lpdf_vec[i] = 0; + } + // if not data (i.e. prior or process), use x vector instead of observed_values + } else { + this->lpdf_vec[i] = dnorm(this->x[i], this->expected_values.get_force_scalar(i), fims_math::exp(log_sd.get_force_scalar(i)), true); + } + lpdf += this->lpdf_vec[i]; + if(this->simulate_flag){ + FIMS_SIMULATE_F(this->of){ + if(this->input_type == "data"){ + this->observed_values->at(i) = rnorm(this->expected_values.get_force_scalar(i), fims_math::exp(log_sd.get_force_scalar(i))); + } else { + this->x[i] = rnorm(this->expected_values.get_force_scalar(i), fims_math::exp(log_sd.get_force_scalar(i))); + } + } + } + #endif + /* osa not working yet + if(osa_flag){//data observation type implements osa residuals + //code for osa cdf method + this->lpdf_vec[i] = this->keep.cdf_lower[i] * log( pnorm(this->x[i], this->expected_values.get_force_scalar(i), sd[i]) ); + this->lpdf_vec[i] = this->keep.cdf_upper[i] * log( 1.0 - pnorm(this->x[i], this->expected_values.get_force_scalar(i), sd[i]) ); + } */ + + } + #ifdef TMB_MODEL + vector normal_x = this->x; + #endif + return(lpdf); + } + +}; + +} // namespace fims_distributions +#endif diff --git a/inst/include/distributions/functors/tmb_distributions.hpp b/inst/include/distributions/functors/tmb_distributions.hpp deleted file mode 100644 index 174273511..000000000 --- a/inst/include/distributions/functors/tmb_distributions.hpp +++ /dev/null @@ -1,108 +0,0 @@ -/** \file tmb_distributions.hpp - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. - * - * The purpose of this file is to declare distribution classes - * which implement distribution functions from TMB. - */ -#ifndef DISTRIBUTIONS_TMB_DISTRIBUTIONS_HPP -#define DISTRIBUTIONS_TMB_DISTRIBUTIONS_HPP - -#ifdef TMB_MODEL - -#include "../../common/fims_vector.hpp" -#include "distributions_base.hpp" - -namespace fims_distributions { - -/** - * @brief Dnorm class returns the TMB dnorm function - */ -template -struct Dnorm : public DistributionsBase { - Type x; /**< observation */ - Type mean; /**< mean of the normal distribution */ - Type sd; /**< standard deviation of the normal distribution, must be strictly - positive.*/ - - Dnorm() : DistributionsBase() {} - - virtual ~Dnorm() {} - - /** - * @brief Probability density function of the normal distribution. - * - * \f[ \frac{1.0}{ sd\sqrt{2\pi} }exp(-\frac{(x - mean)^{2}}{2sd^{2}}) \f] - * - * @param do_log Boolean; if true, log densities are returned - */ - virtual const Type evaluate(const bool& do_log) { - return dnorm(x, mean, sd, do_log); - } -}; - -/** - * @brief Dmultinom class returns the TMB dmultinom function - */ -template -struct Dmultinom : public DistributionsBase { - fims::Vector x; /*!< Vector of length K of integers */ - fims::Vector p; /*!< Vector of length K, specifying the probability for - the K classes (note, unlike in R these must sum to 1). */ - - Dmultinom() : DistributionsBase() {} - - /** - * @brief Probability mass function of the multinomial distribution. - * - * \f[ \frac{n!}{x_{1}! \dots x_{K}!}p_{1}^{x_{1}} \dots p_{K}^{x_{K}} \text{, - * } x_{i} \in \{0,...,n\}, i \in \{1,...,K\}, \text{ with } \sum_{i}x_{i} = n - * \text{ and } \sum^{K}_{k=1}p_{k}=1 \f] - * - * @param do_log Boolean; if true, log densities are returned - */ - virtual const Type evaluate(const bool& do_log) { - return dmultinom(x, p, do_log); - } -}; - -/** - * @brief Dlnorm uses the TMB dnorm function to construct the lognormal density - * function - */ -template -struct Dlnorm : public DistributionsBase { - Type x; /**< observation */ - Type meanlog; /**< mean of the distribution of log(x) */ - Type sdlog; /**< standard deviation of the distribution of log(x) */ - - Dlnorm() : DistributionsBase() {} - - /** - * @brief Probability density function of the lognormal distribution. - * - * \f[ \frac{1.0}{ xsd\sqrt{2.0\pi} }exp(-\frac{(ln(x) - - * mean)^{2.0}}{2.0sd^{2.0}}) \f] - * - * @param do_log Boolean; if true, log densities are returned - */ - - virtual const Type evaluate(const bool& do_log) { - Type logx = log(x); - Type nll; - - nll = dnorm(logx, meanlog, sdlog, true) - logx; - - if (do_log) { - return nll; - } else { - return exp(nll); - } - } -}; -} // namespace fims_distributions - -#endif - -#endif /* DISTRIBUTIONS_TMB_DISTRIBUTIONS_HPP */ diff --git a/inst/include/interface/init.hpp b/inst/include/interface/init.hpp index bc0665982..5d23af44d 100644 --- a/inst/include/interface/init.hpp +++ b/inst/include/interface/init.hpp @@ -1,12 +1,17 @@ +/** + * @file init.hpp + * @brief An interface to dynamically load the functions. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ #ifndef INTERFACE_INIT_HPP #define INTERFACE_INIT_HPP #include #include /** - * - * Callback definition for TMB C++ functions. - * + * @brief Callback definition for TMB C++ functions. */ #ifndef TMB_CALLDEFS #define TMB_CALLDEFS \ @@ -23,20 +28,44 @@ } #endif +/** + * @brief TODO: provide a brief description. + * + */ #define CALLDEF(name, n) \ { #name, (DL_FUNC)&name, n } extern "C" { +/** + * @brief TODO: provide a brief description. + * + * @param mean + * @param nu + * @return SEXP + */ SEXP compois_calc_var(SEXP mean, SEXP nu); +/** + * @brief TODO: provide a brief description. + * + * @return SEXP + */ SEXP omp_check(); +/** + * @brief TODO: provide a brief description. + * + * @return SEXP + */ SEXP omp_num_threads(SEXP); +/** + * @brief TODO: provide a brief description. + * + * @return SEXP + */ SEXP _rcpp_module_boot_fims(); /** - * - *Callback definition to load the FIMS module. - * + * @brief Callback definition to load the FIMS module. */ static const R_CallMethodDef CallEntries[] = { TMB_CALLDEFS, @@ -44,9 +73,8 @@ static const R_CallMethodDef CallEntries[] = { {NULL, NULL, 0}}; /** - * - * FIMS shared object initializer. - * @param dll + * @brief FIMS shared object initializer. + * @param dll TODO: provide a brief description. * */ void R_init_FIMS(DllInfo *dll) { diff --git a/inst/include/interface/interface.hpp b/inst/include/interface/interface.hpp index a6c07ed52..a01219519 100644 --- a/inst/include/interface/interface.hpp +++ b/inst/include/interface/interface.hpp @@ -1,16 +1,16 @@ -/* - * File: interface.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. - * +/** + * @file interface.hpp + * @brief An interface to the modeling platforms, e.g., TMB. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_HPP #define FIMS_INTERFACE_HPP + /* - * Interface file. Uses pre-processing macros + * @brief Interface file. Uses pre-processing macros * to interface with multiple modeling platforms. */ @@ -24,7 +24,7 @@ #include // define REPORT, ADREPORT, and SIMULATE -#define REPORT_F(name, F) \ +#define FIMS_REPORT_F(name, F) \ if (isDouble::value && F->current_parallel_region < 0) { \ Rf_defineVar(Rf_install(#name), PROTECT(asSEXP(name)), F->report); \ UNPROTECT(1); \ @@ -50,8 +50,25 @@ vector ADREPORTvector(vector > x) { return res; } -#define SIMULATE_F(F) if (isDouble::value && F->do_simulate) + + +#define FIMS_SIMULATE_F(F) if (isDouble::value && F->do_simulate) #endif /* TMB_MODEL */ +#ifndef TMB_MODEL + /** + * @brief TODO: provide a brief description. + */ + #define FIMS_SIMULATE_F(F) + /** + * @brief TODO: provide a brief description. + */ + #define FIMS_REPORT_F(name, F) + /** + * @brief TODO: provide a brief description. + */ + #define ADREPORT_F(name, F) +#endif + #endif /* FIMS_INTERFACE_HPP */ diff --git a/inst/include/interface/rcpp/rcpp_interface.hpp b/inst/include/interface/rcpp/rcpp_interface.hpp index 346c8968e..3dc274578 100644 --- a/inst/include/interface/rcpp/rcpp_interface.hpp +++ b/inst/include/interface/rcpp/rcpp_interface.hpp @@ -1,12 +1,10 @@ -/* - * File: rcpp_interface.hpp - * - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file for reuse - * information. - * - * +/** + * @file rcpp_interface.hpp + * @brief The Rcpp interface to declare things. Allows for the use of + * methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_INTERFACE_HPP #define FIMS_INTERFACE_RCPP_INTERFACE_HPP @@ -16,232 +14,357 @@ #include "rcpp_objects/rcpp_growth.hpp" #include "rcpp_objects/rcpp_maturity.hpp" #include "rcpp_objects/rcpp_natural_mortality.hpp" -//#include "rcpp_objects/rcpp_nll.hpp" #include "../../common/model.hpp" #include "rcpp_objects/rcpp_population.hpp" #include "rcpp_objects/rcpp_recruitment.hpp" #include "rcpp_objects/rcpp_selectivity.hpp" -#include "rcpp_objects/rcpp_tmb_distribution.hpp" +#include "rcpp_objects/rcpp_distribution.hpp" +#include "../../utilities/fims_json.hpp" + /** - * @brief Create the TMB model object and add interface objects to it. + * @brief TODO: provide a brief description. + * + */ +SEXP FIMS_objective_function; +/** + * @brief TODO: provide a brief description. + * + */ +SEXP FIMS_gradient_function; +/** + * @brief A double to store the objective function value. + * + */ +double FIMS_function_value = 0; +/** + * @brief TODO: provide a brief description. + * + */ +Rcpp::NumericVector FIMS_function_parameters; +/** + * @brief TODO: provide a brief description. + * + */ +Rcpp::NumericVector FIMS_function_gradient; +/** + * @brief A double to store the maximum gradient component. + * + */ +double FIMS_mgc_value = 0; +/** + * @brief Sets FIMS_finalized to false as the default. + * + */ +bool FIMS_finalized = false; + +/** + * Initializes the logging system, setting all signal handling. + */ +void init_logging() { + std::signal(SIGSEGV, &fims::WriteAtExit); + std::signal(SIGINT, &fims::WriteAtExit); + std::signal(SIGABRT, &fims::WriteAtExit); + std::signal(SIGFPE, &fims::WriteAtExit); + std::signal(SIGILL, &fims::WriteAtExit); + std::signal(SIGTERM, &fims::WriteAtExit); +} + +/** + * @brief Creates the TMB model object and adds interface objects to it. + * + * @details + * This function is called within `initialize_fims()` from R and is not + * typically called by the user directly. */ bool CreateTMBModel() { + init_logging(); + + FIMS_INFO_LOG("adding FIMS objects to TMB"); for (size_t i = 0; i < FIMSRcppInterfaceBase::fims_interface_objects.size(); - i++) { + i++) { FIMSRcppInterfaceBase::fims_interface_objects[i]->add_to_fims_tmb(); } // base model - std::shared_ptr> d0 = - fims_info::Information::GetInstance(); + std::shared_ptr> d0 = + fims_info::Information::GetInstance(); d0->CreateModel(); // first-order derivative - std::shared_ptr> d1 = - fims_info::Information::GetInstance(); + std::shared_ptr> d1 = + fims_info::Information::GetInstance(); d1->CreateModel(); // second-order derivative - std::shared_ptr> d2 = - fims_info::Information::GetInstance(); + std::shared_ptr> d2 = + fims_info::Information::GetInstance(); d2->CreateModel(); // third-order derivative - std::shared_ptr> d3 = - fims_info::Information::GetInstance(); + std::shared_ptr> d3 = + fims_info::Information::GetInstance(); d3->CreateModel(); return true; } -Rcpp::NumericVector get_fixed_parameters_vector() { - // base model - std::shared_ptr> d0 = - fims_info::Information::GetInstance(); - - Rcpp::NumericVector p; +/** + * @brief Loops through the Rcpp Interface objects and extracts derived + * quantities. Updates parameter estimates from model core objects. + */ +void finalize_objects(Rcpp::NumericVector p) { + FIMS_function_parameters = p; + + std::shared_ptr> information = + fims_info::Information::GetInstance(); + + std::shared_ptr> model = + fims_model::Model::GetInstance(); + + for (size_t i = 0; i < information->fixed_effects_parameters.size(); i++) { + *information->fixed_effects_parameters[i] = p[i]; + } + + model->Evaluate(); + + Rcpp::Function f = Rcpp::as(FIMS_objective_function); + Rcpp::Function g = Rcpp::as(FIMS_gradient_function); + double ret = Rcpp::as(f(p)); + Rcpp::NumericVector grad = Rcpp::as(g(p)); + + FIMS_function_value = ret; + FIMS_function_gradient = grad; + Rcpp::Rcout << "Final value = " << FIMS_function_value << "\nGradient: \n"; + double maxgc = -999; + for (R_xlen_t i = 0; i < FIMS_function_gradient.size(); i++) { + if (std::fabs(FIMS_function_gradient[i]) > maxgc) { + maxgc = std::fabs(FIMS_function_gradient[i]); + } + } + FIMS_mgc_value = maxgc; + + for (size_t i = 0; i < FIMSRcppInterfaceBase::fims_interface_objects.size(); + i++) { + FIMSRcppInterfaceBase::fims_interface_objects[i]->finalize(); + } +} - for (size_t i = 0; i < d0->fixed_effects_parameters.size(); i++) { - p.push_back(*d0->fixed_effects_parameters[i]); +/** + * @brief Finalizes a FIMS model by updating the parameter set. This function + * evaluates the objective function and the gradient with the given parameter + * set. + * @param obj Either a list containing \"fn\" and \"gr\", or a list containing + * two separate lists \"obj\" and \"opt\", \"obj\" should contain \"fn\" and + * \"gr\", \"opt\" should contain \"par\". In the second case, the second + * function argument is expected to be null and ignored. + * TODO: Remove the ability to take a single list. + * @param opt A list containing \"par\". + */ +void finalize_fims(Rcpp::Nullable< Rcpp::List> obj = R_NilValue, + Rcpp::Nullable< Rcpp::List> opt = R_NilValue) { + + bool valid_list = true; + Rcpp::NumericVector parameters; + + //check and handle the first argument. + if (!Rf_isNull(obj.get())) { + Rcpp::List input_list = Rcpp::as(obj); + if (input_list.containsElementNamed("obj") + && input_list.containsElementNamed("opt")) { + Rcpp::List obj_list = input_list["obj"]; + Rcpp::List opt_list = input_list["opt"]; + + if (obj_list.containsElementNamed("fn")) { + FIMS_objective_function = obj_list["fn"]; + } else { + valid_list = false; + FIMS_ERROR_LOG("Invalid call, \"fn\" not found in argument list."); + } + + if (obj_list.containsElementNamed("gr")) { + FIMS_gradient_function = obj_list["gr"]; + } else { + valid_list = false; + FIMS_ERROR_LOG("Invalid call, \"gr\" not found in argument list."); + } + + if (opt_list.containsElementNamed("par")) { + parameters = Rcpp::as(opt_list["par"]); + } else { + valid_list = false; + FIMS_ERROR_LOG("Invalid call, \"par\" not found in argument list."); + } + + //if we are here, a single argument was used. if it contains the + //expected elements, the list is valid and objects can be finalize. + if (valid_list) { + finalize_objects(parameters); + FIMS_finalized = true; + return; + } else { + return; + } + + } else {//two arguments? + if (input_list.containsElementNamed("fn")) { + FIMS_objective_function = input_list["fn"]; + } else { + valid_list = false; + FIMS_ERROR_LOG("Invalid call, \"fn\" not found in argument list."); + } + + if (input_list.containsElementNamed("gr")) { + FIMS_gradient_function = input_list["gr"]; + } else { + valid_list = false; + FIMS_ERROR_LOG("Invalid call, \"gr\" not found in argument list."); + } + } } - return p; -} + //check second argument. + if (!Rf_isNull(opt.get())) { -Rcpp::NumericVector get_random_parameters_vector() { - // base model - std::shared_ptr> d0 = - fims_info::Information::GetInstance(); + Rcpp::List input_list = Rcpp::as(opt); - Rcpp::NumericVector p; + if (input_list.containsElementNamed("par")) { + parameters = Rcpp::as(input_list["par"]); + } else { + valid_list = false; + FIMS_ERROR_LOG("Invalid call, \"par\" not found in argument list."); - for (size_t i = 0; i < d0->random_effects_parameters.size(); i++) { - p.push_back(*d0->random_effects_parameters[i]); + } + } else { + valid_list = false; } - return p; + //if we're here, two arguments were given. If they contain the expected + //elements, the lists are valid and objects can be finalized. + if (valid_list) { + finalize_objects(parameters); + FIMS_finalized = true; + } } /** - * Clears the contents of info log file. + * @brief Extracts the derived quantities from model objects. */ -void clear_info_log() { - // First flush the output stream to make sure nothing - // is left in the stream memory bufffer. - INFO_LOG.flush(); - - // Next an new stream is opened and closed to - // overwrite the file. - std::ofstream CLEAR_LOG("logs/info.log"); - CLEAR_LOG.close(); - - // Finally the stream output location is reset back to the start - // of the file. - INFO_LOG.seekp(0); +std::string get_output() { + std::string ret; + if (FIMS_finalized) { + auto now = std::chrono::system_clock::now(); + std::time_t now_time = std::chrono::system_clock::to_time_t(now); + std::string ctime_no_newline = strtok(ctime(&now_time), "\n"); + std::shared_ptr> info = + fims_info::Information::GetInstance(); + std::stringstream ss; + ss << "{\n"; + ss << "\"timestamp\": \"" << ctime_no_newline << "\",\n"; + ss << "\"nyears\":" << info->nyears << ",\n"; + ss << "\"nseasons\":" << info->nseasons << ",\n"; + ss << "\"nages\":" << info->nages << ",\n"; + ss << "\"finalized\":" << FIMS_finalized << ",\n"; + ss << "\"objective_function_value\": " << FIMS_function_value << ",\n"; + ss << "\"max_gradient_component\": " << FIMS_mgc_value << ",\n"; + ss << "\"final_gradient\": ["; + if (FIMS_function_gradient.size() > 0) { + for (R_xlen_t i = 0; i < FIMS_function_gradient.size() - 1; i++) { + ss << FIMS_function_gradient[i] << ", "; + } + ss << FIMS_function_gradient[FIMS_function_gradient.size() - 1] << "],\n"; + } else { + ss << "],"; + } + size_t length = FIMSRcppInterfaceBase::fims_interface_objects.size(); + for (size_t i = 0; i < length - 1; i++) { + ss << FIMSRcppInterfaceBase::fims_interface_objects[i]->to_json() << ",\n"; + } + + ss << FIMSRcppInterfaceBase::fims_interface_objects[length - 1]->to_json() << "\n}"; + + ret = fims::JsonParser::PrettyFormatJSON(ss.str()); + } else { + Rcpp::Rcout << "Invalid request to \"get_output()\". Please call finalize() first."; + } + return ret; } /** - * Clears the contents of fims log file. + * @brief Gets the fixed parameters vector object. + * + * @return Rcpp::NumericVector */ -void clear_fims_log() { - FIMS_LOG.flush(); - std::ofstream CLEAR_LOG("logs/fims.log"); - CLEAR_LOG.close(); - FIMS_LOG.seekp(0); -} +Rcpp::NumericVector get_fixed_parameters_vector() { + // base model + std::shared_ptr> d0 = + fims_info::Information::GetInstance(); -/** - * Clears the contents of data log file. - */ -void clear_data_log() { - DATA_LOG.flush(); - std::ofstream CLEAR_LOG("logs/data.log"); - CLEAR_LOG.close(); - DATA_LOG.seekp(0); -} + Rcpp::NumericVector p; -/** - * Clears the contents of error log file. - */ -void clear_error_log() { - ERROR_LOG.flush(); - std::ofstream CLEAR_LOG("logs/error.log"); - CLEAR_LOG.close(); - ERROR_LOG.seekp(0); -} + for (size_t i = 0; i < d0->fixed_effects_parameters.size(); i++) { + p.push_back(*d0->fixed_effects_parameters[i]); + } -/** - * Clears the contents of model log file. - */ -void clear_model_log() { - MODEL_LOG.flush(); - std::ofstream CLEAR_LOG("logs/model.log"); - CLEAR_LOG.close(); - MODEL_LOG.seekp(0); + return p; } /** - * Clears the contents of fleet log file. + * @brief Gets the random parameters vector object. + * + * @return Rcpp::NumericVector */ -void clear_fleet_log() { - FLEET_LOG.flush(); - std::ofstream CLEAR_LOG("logs/fleet.log"); - CLEAR_LOG.close(); - FLEET_LOG.seekp(0); -} +Rcpp::NumericVector get_random_parameters_vector() { + // base model + std::shared_ptr> d0 = + fims_info::Information::GetInstance(); -/** - * Clears the contents of population log file. - */ -void clear_population_log() { - POPULATION_LOG.flush(); - std::ofstream CLEAR_LOG("logs/population.log"); - CLEAR_LOG.close(); - POPULATION_LOG.seekp(0); -} + Rcpp::NumericVector p; -/** - * Clears the contents of maturity log file. - */ -void clear_maturity_log() { - MATURITY_LOG.flush(); - std::ofstream CLEAR_LOG("logs/maturity.log"); - CLEAR_LOG.close(); - MATURITY_LOG.seekp(0); -} + for (size_t i = 0; i < d0->random_effects_parameters.size(); i++) { + p.push_back(*d0->random_effects_parameters[i]); + } -/** - * Clears the contents of recruitment log file. - */ -void clear_recruitment_log() { - RECRUITMENT_LOG.flush(); - std::ofstream CLEAR_LOG("logs/recruitment.log"); - CLEAR_LOG.close(); - RECRUITMENT_LOG.seekp(0); + return p; } /** - * Clears the contents of growth log file. + * @brief Gets the parameter names object. + * + * @param pars + * @return Rcpp::List */ -void clear_growth_log() { - GROWTH_LOG.flush(); - std::ofstream CLEAR_LOG("logs/growth.log"); - CLEAR_LOG.close(); - GROWTH_LOG.seekp(0); -} +Rcpp::List get_parameter_names(Rcpp::List pars) { + // base model + std::shared_ptr> d0 = + fims_info::Information::GetInstance(); -/** - * Clears the contents of selectivity log file. - */ -void clear_selectivity_log() { - SELECTIVITY_LOG.flush(); - std::ofstream CLEAR_LOG("logs/selectivity.log"); - CLEAR_LOG.close(); - SELECTIVITY_LOG.seekp(0); -} + pars.attr("names") = d0->parameter_names; -/** - * Clears the contents of debug log file. - */ -void clear_debug_log() { - DEBUG_LOG.flush(); - std::ofstream CLEAR_LOG("logs/debug/debug.log"); - CLEAR_LOG.close(); - DEBUG_LOG.seekp(0); + return pars; } /** - * Clears the contents of log files. + * @brief Clears the internal objects. + * + * @tparam Type */ -void clear_logs() { - clear_fims_log(); - clear_info_log(); - clear_data_log(); - clear_error_log(); - clear_model_log(); - clear_fleet_log(); - clear_population_log(); - clear_recruitment_log(); - clear_growth_log(); - clear_maturity_log(); - clear_selectivity_log(); - clear_debug_log(); -} - template void clear_internal() { - std::shared_ptr> d0 = - fims_info::Information::GetInstance(); - d0->fixed_effects_parameters.clear(); - d0->random_effects_parameters.clear(); + std::shared_ptr> d0 = + fims_info::Information::GetInstance(); + d0->Clear(); } + /** - * Clears the vector of independent variables. + * @brief Clears the vector of independent variables. */ void clear() { // rcpp_interface_base.hpp FIMSRcppInterfaceBase::fims_interface_objects.clear(); + //Parameter and ParameterVector + Parameter::id_g = 1; + ParameterVector::id_g = 1; // rcpp_data.hpp DataInterfaceBase::id_g = 1; DataInterfaceBase::live_objects.clear(); @@ -249,6 +372,9 @@ void clear() { AgeCompDataInterface::id_g = 1; AgeCompDataInterface::live_objects.clear(); + LengthCompDataInterface::id_g = 1; + LengthCompDataInterface::live_objects.clear(); + IndexDataInterface::id_g = 1; IndexDataInterface::live_objects.clear(); @@ -297,7 +423,7 @@ void clear() { DoubleLogisticSelectivityInterface::id_g = 1; DoubleLogisticSelectivityInterface::live_objects.clear(); - // rcpp_tmb_distribution.hpp + // rcpp_distribution.hpp DistributionsInterfaceBase::id_g = 1; DistributionsInterfaceBase::live_objects.clear(); @@ -314,50 +440,275 @@ void clear() { clear_internal(); clear_internal(); clear_internal(); + + fims::FIMSLog::fims_log->clear(); + + FIMS_finalized = false; +} + +/** + * @brief Gets the log entries as a string in JSON format. + */ +std::string get_log() { + return fims::FIMSLog::fims_log->get_log(); +} + +/** + * @brief Gets the error entries from the log as a string in JSON format. + */ +std::string get_log_errors() { + return fims::FIMSLog::fims_log->get_errors(); +} + +/** + * @brief Gets the warning entries from the log as a string in JSON format. + */ +std::string get_log_warnings() { + return fims::FIMSLog::fims_log->get_warnings(); +} + +/** + * @brief Gets the info entries from the log as a string in JSON format. + */ +std::string get_log_info() { + return fims::FIMSLog::fims_log->get_info(); +} + +/** + * @brief Gets log entries by module as a string in JSON format. + */ +std::string get_log_module(const std::string& module) { + return fims::FIMSLog::fims_log->get_module(module); +} + +/** + * @brief If true, writes the log on exit. + */ +void write_log(bool write) { + FIMS_INFO_LOG("Setting FIMS write log: " + fims::to_string(write)); + fims::FIMSLog::fims_log->write_on_exit = write; +} + +/** + * @brief Sets the path for the log file to be written to. + */ +void set_log_path(const std::string& path) { + FIMS_INFO_LOG("Setting FIMS log path: " + path); + fims::FIMSLog::fims_log->set_path(path); +} + +/** + * @brief If true, throws a runtime exception when an error is logged. + */ +void set_log_throw_on_error(bool throw_on_error) { + fims::FIMSLog::fims_log->throw_on_error = throw_on_error; +} + +/** + * @brief Adds an info entry to the log from the R environment. + */ +void log_info(std::string log_entry) { + fims::FIMSLog::fims_log->info_message(log_entry, -1, "R_env", "R_script_entry"); +} + +/** + * @brief Adds a warning entry to the log from the R environment. + */ +void log_warning(std::string log_entry) { + fims::FIMSLog::fims_log->warning_message(log_entry, -1, "R_env", "R_script_entry"); +} + +/** + * @brief Escapes quotations. + * + * @param input A string. + * @return std::string + */ +std::string escapeQuotes(const std::string& input) { + std::string result = input; + std::string search = "\""; + std::string replace = "\\\""; + + // Find each occurrence of `"` and replace it with `\"` + size_t pos = result.find(search); + while (pos != std::string::npos) { + result.replace(pos, search.size(), replace); + pos = result.find(search, pos + replace.size()); // Move past the replaced position + } + return result; +} + +/** + * @brief Adds a error entry to the log from the R environment. + */ +void log_error(std::string log_entry) { + std::stringstream ss; + ss << "capture.output(traceback(4))"; + SEXP expression, result; + ParseStatus status; + + PROTECT(expression = R_ParseVector(Rf_mkString(ss.str().c_str()), 1, &status, R_NilValue)); + if (status != PARSE_OK) { + Rcpp::Rcout << "Error parsing expression" << std::endl; + UNPROTECT(1); + } + Rcpp::Rcout << "before call."; + PROTECT(result = Rf_eval(VECTOR_ELT(expression, 0), R_GlobalEnv)); + Rcpp::Rcout << "after call."; + UNPROTECT(2); + std::stringstream ss_ret; + ss_ret << "traceback: "; + for (int j = 0; j < LENGTH(result); j++) { + std::string str(CHAR(STRING_ELT(result, j))); + ss_ret << escapeQuotes(str) << "\\n"; + } + + std::string ret = ss_ret.str(); //"find error";//Rcpp::as(result); + + fims::FIMSLog::fims_log->error_message(log_entry, -1, "R_env", ret.c_str()); } RCPP_EXPOSED_CLASS(Parameter) +RCPP_EXPOSED_CLASS(ParameterVector) + +/** + * @brief The `fims` Rcpp module construct, providing declarative code of what + * the module exposes to R. + * + * @details Each element included in the module should have a name, a pointer, + * and a description separated by commas in that order. Both the name and the + * description should be wrapped in quotes. The description is printed to the + * screen when the R function `methods::show()` is used on the object. The + * available description should exactly match the information found in the + * brief tag where the function, class, etc. is documented. See the Rcpp + * vignette for more information on documenting modules, particularly how to + * include lists for parameters to a function. Each of the functions included + * in this module should be exported by manually exporting them in + * R/FIMS-package.R. + * + */ RCPP_MODULE(fims) { - Rcpp::function("CreateTMBModel", &CreateTMBModel); - Rcpp::function("get_fixed", &get_fixed_parameters_vector); - Rcpp::function("get_random", &get_random_parameters_vector); - Rcpp::function("clear", clear); - Rcpp::function("clear_logs", clear_logs); - Rcpp::function("clear_fims_log", clear_fims_log); - Rcpp::function("clear_info_log", clear_info_log); - Rcpp::function("clear_error_log", clear_error_log); - Rcpp::function("clear_data_log", clear_data_log); - Rcpp::function("clear_population_log", clear_population_log); - Rcpp::function("clear_model_log", clear_model_log); - Rcpp::function("clear_recruitment_log", clear_recruitment_log); - Rcpp::function("clear_fleet_log", clear_fleet_log); - Rcpp::function("clear_growth_log", clear_growth_log); - Rcpp::function("clear_maturity_log", clear_maturity_log); - Rcpp::function("clear_selectivity_log", clear_selectivity_log); - Rcpp::function("clear_debug_log", clear_debug_log); - - Rcpp::class_("Parameter") - .constructor() - .constructor() - .constructor() - .field("value", &Parameter::value_m) - .field("min", &Parameter::min_m) - .field("max", &Parameter::max_m) - .field("is_random_effect", &Parameter::is_random_effect_m) - .field("estimated", &Parameter::estimated_m); - - Rcpp::class_("BevertonHoltRecruitment") - .constructor() - .field("logit_steep", &BevertonHoltRecruitmentInterface::logit_steep) - .field("log_rzero", &BevertonHoltRecruitmentInterface::log_rzero) - .field("log_devs", &BevertonHoltRecruitmentInterface::log_devs) - .field("estimate_log_devs", - &BevertonHoltRecruitmentInterface::estimate_log_devs) - .method("get_id", &BevertonHoltRecruitmentInterface::get_id) - .field("log_sigma_recruit", - &BevertonHoltRecruitmentInterface::log_sigma_recruit) - .method("evaluate", &BevertonHoltRecruitmentInterface::evaluate) - .method("evaluate_nll", &BevertonHoltRecruitmentInterface::evaluate_nll); + Rcpp::function( + "CreateTMBModel", &CreateTMBModel, + "Creates the TMB model object and adds interface objects to it."); + Rcpp::function( + "finalize", &finalize_fims, + "Extracts the derived quantities from `Information` to the Rcpp object."); + Rcpp::function( + "get_output", &get_output, + "Extracts the derived quantities from model objects."); + Rcpp::function( + "get_fixed", &get_fixed_parameters_vector, + "Gets the fixed parameters vector object."); + Rcpp::function( + "get_random", &get_random_parameters_vector, + "Gets the random parameters vector object."); + Rcpp::function( + "get_parameter_names", &get_parameter_names, + "Gets the parameter names object."); + Rcpp::function( + "clear", clear, + "Clears all pointers/references of a FIMS model"); + Rcpp::function( + "get_log", get_log, + "Gets the log entries as a string in JSON format."); + Rcpp::function( + "get_log_errors", get_log_errors, + "Gets the error entries from the log as a string in JSON format."); + Rcpp::function( + "get_log_warnings", get_log_warnings, + "Gets the warning entries from the log as a string in JSON format."); + Rcpp::function( + "get_log_info", get_log_info, + "Gets the info entries from the log as a string in JSON format."); + Rcpp::function( + "get_log_module", get_log_module, + "Gets log entries by module as a string in JSON format."); + Rcpp::function( + "write_log", write_log, + "If true, writes the log on exit."); + Rcpp::function( + "set_log_path", set_log_path, + "Sets the path for the log file to be written to."); + Rcpp::function( + "init_logging", init_logging, + "Initializes the logging system, setting all signal handling."); + Rcpp::function( + "set_log_throw_on_error", set_log_throw_on_error, + "If true, throws a runtime exception when an error is logged."); + Rcpp::function( + "log_info", log_info, + "Adds an info entry to the log from the R environment."); + Rcpp::function( + "log_warning", log_warning, + "Adds a warning entry to the log from the R environment."); + Rcpp::function( + "log_error", log_error, + "Adds a error entry to the log from the R environment."); + Rcpp::class_( + "Parameter", + "An RcppInterface class that defines the Parameter class.") + .constructor() + .constructor() + .constructor() + .field( + "value", &Parameter::initial_value_m, + "A numeric value specifying the initial value of the parameter.") + .field( + "value", &Parameter::final_value_m, + "A numeric value specifying the final value of the parameter.") + .field( + "min", &Parameter::min_m, + "A numeric value specifying the minimum possible parameter value, where the default is negative infinity.") + .field( + "max", &Parameter::max_m, + "A numeric value specifying the maximum possible parameter value, where the default is positive infinity.") + .field( + "id", &Parameter::id_m, + "unique id for parameter class") + .field( + "is_random_effect", &Parameter::is_random_effect_m, + "A boolean indicating whether or not the parameter is a random effect; the default is FALSE.") + .field( + "estimated", &Parameter::estimated_m, + "A boolean indicating whether or not the parameter is estimated; the default is FALSE."); + + Rcpp::class_( + "ParameterVector", + "An RcppInterface class that defines the ParameterVector class.") + .constructor() + .constructor() + .constructor() + .method("get", &ParameterVector::get, + "An internal accessor for calling a position of a ParameterVector from R.") + .method("set", &ParameterVector::set, + "An internal setter for setting a position of a ParameterVector from R.") + .method("show", &ParameterVector::show, + "The printing methods for a ParameterVector.") + .method("at", &ParameterVector::at, + "Returns a Parameter at the indicated position given the index argument.") + .method("size", &ParameterVector::size, + "Returns the size of a ParameterVector.") + .method("resize", &ParameterVector::resize, + "Resizes a ParameterVector to the desired length.") + .method("set_all_estimable", &ParameterVector::set_all_estimable, + "Sets all Parameters within a ParameterVector as estimable.") + .method("set_all_random", &ParameterVector::set_all_random, + "Sets all Parameters within a ParameterVector as random effects.") + .method("fill", &ParameterVector::fill, + "Sets the value of all Parameters in the ParameterVector to the provided value.") + .method("get_id", &ParameterVector::get_id, + "Gets the ID of the ParameterVector object."); + + Rcpp::class_("BevertonHoltRecruitment") + .constructor() + .field("logit_steep", &BevertonHoltRecruitmentInterface::logit_steep) + .field("log_rzero", &BevertonHoltRecruitmentInterface::log_rzero) + .field("log_devs", &BevertonHoltRecruitmentInterface::log_devs) + .field("estimate_log_devs", + &BevertonHoltRecruitmentInterface::estimate_log_devs) + .method("get_id", &BevertonHoltRecruitmentInterface::get_id) + .method("evaluate", &BevertonHoltRecruitmentInterface::evaluate); Rcpp::class_("Fleet") .constructor() @@ -366,103 +717,131 @@ RCPP_MODULE(fims) { .field("log_Fmort", &FleetInterface::log_Fmort) .field("nages", &FleetInterface::nages) .field("nyears", &FleetInterface::nyears) - .field("estimate_F", &FleetInterface::estimate_F) + .field("nlengths", &FleetInterface::nlengths) .field("estimate_q", &FleetInterface::estimate_q) - .field("estimate_obs_error", &FleetInterface::estimate_obs_error) .field("random_q", &FleetInterface::random_q) - .field("random_F", &FleetInterface::random_F) - .field("log_obs_error", &FleetInterface::log_obs_error) - .method("SetAgeCompLikelihood", &FleetInterface::SetAgeCompLikelihood) - .method("SetIndexLikelihood", &FleetInterface::SetIndexLikelihood) + .field("log_expected_index", &FleetInterface::log_expected_index) + .field("proportion_catch_numbers_at_age", &FleetInterface::proportion_catch_numbers_at_age) + .field("proportion_catch_numbers_at_length", &FleetInterface::proportion_catch_numbers_at_length) + .field("age_length_conversion_matrix", &FleetInterface::age_length_conversion_matrix) .method("SetObservedAgeCompData", &FleetInterface::SetObservedAgeCompData) + .method("GetObservedAgeCompDataID", &FleetInterface::GetObservedAgeCompDataID) + .method("SetObservedLengthCompData", &FleetInterface::SetObservedLengthCompData) + .method("GetObservedLengthCompDataID", &FleetInterface::GetObservedLengthCompDataID) .method("SetObservedIndexData", &FleetInterface::SetObservedIndexData) + .method("GetObservedIndexDataID", &FleetInterface::GetObservedIndexDataID) .method("SetSelectivity", &FleetInterface::SetSelectivity); - Rcpp::class_("AgeComp") - .constructor() - .field("age_comp_data", &AgeCompDataInterface::age_comp_data) - .method("get_id", &AgeCompDataInterface::get_id); - - Rcpp::class_("Index") - .constructor() - .field("index_data", &IndexDataInterface::index_data) - .method("get_id", &IndexDataInterface::get_id); - - Rcpp::class_("Population") - .constructor() - .method("get_id", &PopulationInterface::get_id) - .field("nages", &PopulationInterface::nages) - .field("nfleets", &PopulationInterface::nfleets) - .field("nseasons", &PopulationInterface::nseasons) - .field("nyears", &PopulationInterface::nyears) - .field("log_M", &PopulationInterface::log_M) - .field("log_init_naa", &PopulationInterface::log_init_naa) - .field("proportion_female", &PopulationInterface::proportion_female) - .field("ages", &PopulationInterface::ages) - .field("estimate_M", &PopulationInterface::estimate_M) - .field("estimate_init_naa", &PopulationInterface::estimate_initNAA) - .field("estimate_prop_female", &PopulationInterface::estimate_prop_female) - .method("evaluate", &PopulationInterface::evaluate) - .method("SetMaturity", &PopulationInterface::SetMaturity) - .method("SetGrowth", &PopulationInterface::SetGrowth) - .method("SetRecruitment", &PopulationInterface::SetRecruitment) - .method("evaluate", &PopulationInterface::evaluate); - - Rcpp::class_("TMBDnormDistribution") - .constructor() - .method("get_id", &DnormDistributionsInterface::get_id) - .method("evaluate", &DnormDistributionsInterface::evaluate) - .field("x", &DnormDistributionsInterface::x) - .field("mean", &DnormDistributionsInterface::mean) - .field("sd", &DnormDistributionsInterface::sd); - - Rcpp::class_("LogisticMaturity") - .constructor() - .field("inflection_point", &LogisticMaturityInterface::inflection_point) - .field("slope", &LogisticMaturityInterface::slope) - .method("get_id", &LogisticMaturityInterface::get_id) - .method("evaluate", &LogisticMaturityInterface::evaluate); - - Rcpp::class_("LogisticSelectivity") - .constructor() - .field("inflection_point", - &LogisticSelectivityInterface::inflection_point) - .field("slope", &LogisticSelectivityInterface::slope) - .method("get_id", &LogisticSelectivityInterface::get_id) - .method("evaluate", &LogisticSelectivityInterface::evaluate); - - Rcpp::class_("DoubleLogisticSelectivity") - .constructor() - .field("inflection_point_asc", - &DoubleLogisticSelectivityInterface::inflection_point_asc) - .field("slope_asc", &DoubleLogisticSelectivityInterface::slope_asc) - .field("inflection_point_desc", - &DoubleLogisticSelectivityInterface::inflection_point_desc) - .field("slope_desc", &DoubleLogisticSelectivityInterface::slope_desc) - .method("get_id", &DoubleLogisticSelectivityInterface::get_id) - .method("evaluate", &DoubleLogisticSelectivityInterface::evaluate); - - Rcpp::class_("EWAAgrowth") - .constructor() - .field("ages", &EWAAGrowthInterface::ages) - .field("weights", &EWAAGrowthInterface::weights) - .method("get_id", &EWAAGrowthInterface::get_id) - .method("evaluate", &EWAAGrowthInterface::evaluate); - - Rcpp::class_("TMBDlnormDistribution") - .constructor() - .method("get_id", &DlnormDistributionsInterface::get_id) - .method("evaluate", &DlnormDistributionsInterface::evaluate) - .field("x", &DlnormDistributionsInterface::x) - .field("meanlog", &DlnormDistributionsInterface::meanlog) - .field("sdlog", &DlnormDistributionsInterface::sdlog); - - Rcpp::class_("TMBDmultinomDistribution") - .constructor() - .method("evaluate", &DmultinomDistributionsInterface::evaluate) - .method("get_id", &DmultinomDistributionsInterface::get_id) - .field("x", &DmultinomDistributionsInterface::x) - .field("p", &DmultinomDistributionsInterface::p); + Rcpp::class_("AgeComp") + .constructor() + .field("age_comp_data", &AgeCompDataInterface::age_comp_data) + .method("get_id", &AgeCompDataInterface::get_id); + + Rcpp::class_("LengthComp") + .constructor() + .field("length_comp_data", &LengthCompDataInterface::length_comp_data) + .method("get_id", &LengthCompDataInterface::get_id); + + Rcpp::class_("Index") + .constructor() + .field("index_data", &IndexDataInterface::index_data) + .method("get_id", &IndexDataInterface::get_id); + + Rcpp::class_("Population") + .constructor() + .method("get_id", &PopulationInterface::get_id, "get population ID") + .field("nages", &PopulationInterface::nages, "number of ages") + .field("nfleets", &PopulationInterface::nfleets, "number of fleets") + .field("nseasons", &PopulationInterface::nseasons, "number of seasons") + .field("nyears", &PopulationInterface::nyears, "number of years") + .field("nlengths", &PopulationInterface::nlengths, "number of lengths") + .field("log_M", &PopulationInterface::log_M, "natural log of the natural mortality of the population") + .field("log_init_naa", &PopulationInterface::log_init_naa, "natural log of the initial numbers at age") + .field("ages", &PopulationInterface::ages, "vector of ages in the population; length nages") + .method("evaluate", &PopulationInterface::evaluate, "evaluate the population function") + .method("SetMaturity", &PopulationInterface::SetMaturity, "Set the unique id for the Maturity object") + .method("SetGrowth", &PopulationInterface::SetGrowth, "Set the unique id for the growth object") + .method("SetRecruitment", &PopulationInterface::SetRecruitment, "Set the unique id for the Recruitment object") + .method("evaluate", &PopulationInterface::evaluate, "evaluate the population function"); + + Rcpp::class_("LogisticMaturity") + .constructor() + .field("inflection_point", &LogisticMaturityInterface::inflection_point) + .field("slope", &LogisticMaturityInterface::slope) + .method("get_id", &LogisticMaturityInterface::get_id) + .method("evaluate", &LogisticMaturityInterface::evaluate); + + Rcpp::class_("LogisticSelectivity") + .constructor() + .field("inflection_point", + &LogisticSelectivityInterface::inflection_point) + .field("slope", &LogisticSelectivityInterface::slope) + .method("get_id", &LogisticSelectivityInterface::get_id) + .method("evaluate", &LogisticSelectivityInterface::evaluate); + + Rcpp::class_("DoubleLogisticSelectivity") + .constructor() + .field( + "inflection_point_asc", + &DoubleLogisticSelectivityInterface::inflection_point_asc, + "50 percent quantile of the value of the quantity of interest (x) on the ascending limb of the double logistic curve; e.g., age at which 50 percent of the fish are selected.") + .field( + "slope_asc", + &DoubleLogisticSelectivityInterface::slope_asc, + "Scalar multiplier of difference between quantity of interest value (x) and inflection_point on the ascending limb of the double logistic curve.") + .field( + "inflection_point_desc", + &DoubleLogisticSelectivityInterface::inflection_point_desc, + "50 percent quantile of the value of the quantity of interest (x) on the descending limb of the double logistic curve; e.g. age at which 50 percent of the fish are selected.") + .field( + "slope_desc", + &DoubleLogisticSelectivityInterface::slope_desc, + "Scalar multiplier of difference between quantity of interest value (x) and inflection_point on the descending limb of the double logistic curve.") + .method( + "get_id", + &DoubleLogisticSelectivityInterface::get_id, + "Returns a unique ID for the selectivity class.") + .method( + "evaluate", + &DoubleLogisticSelectivityInterface::evaluate, + "Evaluates the double logistic selectivity given input value (e.g., age or size in selectivity)."); + + Rcpp::class_("EWAAgrowth") + .constructor() + .field("ages", &EWAAGrowthInterface::ages, "Ages for each age class.") + .field("weights", &EWAAGrowthInterface::weights, "Weights for each age class.") + .method("get_id", &EWAAGrowthInterface::get_id) + .method("evaluate", &EWAAGrowthInterface::evaluate); + + Rcpp::class_("DnormDistribution") + .constructor() + .method("get_id", &DnormDistributionsInterface::get_id, "Returns a unique ID for the Dnorm distribution class.") + .method("evaluate", &DnormDistributionsInterface::evaluate, "Evaluates the normal distribution given input data and parameter values.") + .method("set_observed_data", &DnormDistributionsInterface::set_observed_data, "Accepts a unique ID for a given Data Object class to link the data with the distribution.") + .method("set_distribution_links", &DnormDistributionsInterface::set_distribution_links, "Accepts a unique ID for a given parameter to link the parameter with the distribution.") + .field("x", &DnormDistributionsInterface::x, "Input for distribution when not observations, e.g., prior or random effect.") + .field("expected_values", &DnormDistributionsInterface::expected_values, "Mean of the distribution.") + .field("log_sd", &DnormDistributionsInterface::log_sd, "The natural log of the standard deviation."); + + Rcpp::class_("DlnormDistribution") + .constructor() + .method("get_id", &DlnormDistributionsInterface::get_id, "Returns a unique ID for the Dnorm distribution class.") + .method("evaluate", &DlnormDistributionsInterface::evaluate, "Evaluates the normal distribution given input data and parameter values.") + .method("set_observed_data", &DlnormDistributionsInterface::set_observed_data, "Accepts a unique ID for a given Data Object class to link the data with the distribution.") + .method("set_distribution_links", &DlnormDistributionsInterface::set_distribution_links, "Accepts a unique ID for a given parameter to link the parameter with the distribution.") + .field("x", &DlnormDistributionsInterface::x, "Input for distribution when not observations, e.g., prior or random effect.") + .field("expected_values", &DlnormDistributionsInterface::expected_values, "Mean of the distribution on the natural log scale.") + .field("log_sd", &DlnormDistributionsInterface::log_sd, "The natural log of the standard deviation of the distribution on the natural log scale."); + + Rcpp::class_("DmultinomDistribution") + .constructor() + .method("get_id", &DmultinomDistributionsInterface::get_id, "Returns a unique ID for the Dnorm distribution class.") + .method("evaluate", &DmultinomDistributionsInterface::evaluate, "Evaluates the normal distribution given input data and parameter values.") + .method("set_observed_data", &DmultinomDistributionsInterface::set_observed_data, "Accepts a unique ID for a given Data Object class to link the data with the distribution.") + .method("set_distribution_links", &DmultinomDistributionsInterface::set_distribution_links, "Accepts a unique ID for a given parameter to link the parameter with the distribution.") + .field("x", &DmultinomDistributionsInterface::x, "Input for distribution when not observations, e.g., prior or random effect.") + .field("expected_values", &DmultinomDistributionsInterface::expected_values, "numeric non-negative vector of length K, specifying the probability for the K classes.") + .field("dims", &DmultinomDistributionsInterface::dims, "dimension of the multivariate input, e.g., c(num rows, num cols)."); } #endif /* RCPP_INTERFACE_HPP */ diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_data.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_data.hpp index 3f25e3f7e..fc86efd5a 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_data.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_data.hpp @@ -1,9 +1,10 @@ -/* - * File: rcpp_fleet.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. +/** + * @file rcpp_fleet.hpp + * @brief The Rcpp interface to declare different types of data, e.g., + * age-composition and index data. Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_DATA_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_DATA_HPP @@ -12,22 +13,33 @@ #include "rcpp_interface_base.hpp" /** - * @brief Rcpp interface for Data as an S4 object. To instantiate - * from R: - * fleet <- new(Data) - * + * @brief Rcpp interface that serves as the parent class for Rcpp data + * interfaces. This type should be inherited and not called from R directly. */ class DataInterfaceBase : public FIMSRcppInterfaceBase { public: - Rcpp::NumericVector observed_data; /**< The data */ - static uint32_t id_g; /**< static id of the DataInterfaceBase object */ - uint32_t id; /**< local id of the DataInterfaceBase object */ - // live objects in C++ are objects that have been created and live in memory - static std::map - live_objects; /**< map associating the ids of DataInterfaceBase to - the objects */ + /** + * @brief The vector of data that is being passed from R. + */ + Rcpp::NumericVector observed_data; + /** + * @brief The static id of the DataInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local id of the DataInterfaceBase object. + * + */ + uint32_t id; + /** + * @brief The map associating the IDs of DataInterfaceBase to the objects. + * This is a live object, which is an object that has been created and lives + * in memory. + */ + static std::map live_objects; - /** @brief constructor + /** + * @brief The constructor. */ DataInterfaceBase() { this->id = DataInterfaceBase::id_g++; @@ -37,35 +49,50 @@ class DataInterfaceBase : public FIMSRcppInterfaceBase { FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); } - /** @brief destructor + /** + * @brief The destructor. */ virtual ~DataInterfaceBase() {} - /** @brief get the ID of the interface base object + /** + * @brief Get the ID for the child data interface objects to inherit. */ virtual uint32_t get_id() { return this->id; } - /**@brief add_to_fims_tmb dummy method - * + /** + * @brief Adds the parameters to the TMB model. */ virtual bool add_to_fims_tmb() { return true; }; }; +// static id of the DataInterfaceBase object uint32_t DataInterfaceBase::id_g = 1; +// local id of the DataInterfaceBase object map relating the ID of the +// DataInterfaceBase to the DataInterfaceBase objects std::map DataInterfaceBase::live_objects; /** - * @brief Rcpp interface for age comp data as an S4 object. To instantiate - * from R: - * acomp <- new(AgeComp) + * @brief The Rcpp interface for AgeComp to instantiate the object from R: + * acomp <- methods::new(AgeComp). */ class AgeCompDataInterface : public DataInterfaceBase { public: - int amax; /**< first dimension of the data */ - int ymax; /**< second dimension of the data */ - Rcpp::NumericVector age_comp_data; /**amax = amax; @@ -73,13 +100,41 @@ class AgeCompDataInterface : public DataInterfaceBase { } /** - * @brief destructor + * @brief The destructor. */ virtual ~AgeCompDataInterface() {} - /** @brief get the ID of the interface base object + /** + * @brief Gets the ID of the interface base object. + * @return The ID. */ virtual uint32_t get_id() { return this->id; } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * data interface with age-composition data. It also returns the ID, the rank + * of 2, the dimensions by printing ymax and amax, followed by the data values + * themselves. This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"data\",\n"; + ss << " \"type\" : \"AgeComp\",\n"; + ss << " \"id\":" << this->id << ",\n"; + ss << " \"rank\": " << 2 << ",\n"; + ss << " \"dimensions\": [" << this->ymax << "," << this->amax << "],\n"; + ss << " \"values\": ["; + for (R_xlen_t i = 0; i < age_comp_data.size() - 1; i++) { + ss << age_comp_data[i] << ", "; + } + ss << age_comp_data[age_comp_data.size() - 1] << "]\n"; + ss << "}"; + return ss.str(); + } + #ifdef TMB_MODEL @@ -106,7 +161,8 @@ class AgeCompDataInterface : public DataInterfaceBase { } /** - * @brief adds parameters to the model + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. */ virtual bool add_to_fims_tmb() { this->add_to_fims_tmb_internal(); @@ -121,28 +177,158 @@ class AgeCompDataInterface : public DataInterfaceBase { }; /** - * @brief Rcpp interface for data as an S4 object. To instantiate - * from R: - * fleet <- new(Index) + * @brief The Rcpp interface for LengthComp to instantiate the object from R: + * lcomp <- methods::new(LengthComp). + */ +class LengthCompDataInterface : public DataInterfaceBase { + public: + /** + * @brief The first dimension of the data, which relates to the number of + * length bins. + */ + int lmax; + /** + * @brief The second dimension of the data, which relates to the number of + * time steps or years. + */ + int ymax; + /** + * @brief The vector of length-composition data that is being passed from R. + */ + Rcpp::NumericVector length_comp_data; + + /** + * @brief The constructor. + */ + LengthCompDataInterface(int ymax = 0, int lmax = 0) : DataInterfaceBase() { + this->lmax = lmax; + this->ymax = ymax; + } + + /** + * @brief The destructor. + */ + virtual ~LengthCompDataInterface() {} + + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ + virtual uint32_t get_id() { return this->id; } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * data interface with length-composition data. It also returns the ID, the + * rank of 2, the dimensions by printing ymax and lmax, followed by the data + * values themselves. This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"data\",\n"; + ss << " \"type\" : \"LengthComp\",\n"; + ss << " \"id\":" << this->id << ",\n"; + ss << " \"rank\": " << 2 << ",\n"; + ss << " \"dimensions\": [" << this->ymax << "," << this->lmax << "],\n"; + ss << " \"values\": ["; + for (R_xlen_t i = 0; i < length_comp_data.size() - 1; i++) { + ss << length_comp_data[i] << ", "; + } + ss << length_comp_data[length_comp_data.size() - 1] << "]\n"; + ss << "}"; + return ss.str(); + } + +#ifdef TMB_MODEL + template + bool add_to_fims_tmb_internal() { + std::shared_ptr> length_comp_data = + std::make_shared>(this->ymax, + this->lmax); + length_comp_data->id = this->id; + for (int y = 0; y < ymax; y++) { + for (int l = 0; l < lmax; l++) { + int i_length_year = y * lmax + l; + length_comp_data->at(y, l) = this->length_comp_data[i_length_year]; + } + } + std::shared_ptr> info = + fims_info::Information::GetInstance(); + info->data_objects[this->id] = length_comp_data; + return true; + } + + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ + virtual bool add_to_fims_tmb() { + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + return true; + } +#endif +}; + +/** + * @brief The Rcpp interface for Index to instantiate the object from R: + * fleet <- methods::new(Index). */ class IndexDataInterface : public DataInterfaceBase { public: - int ymax; /**< second dimension of the data */ - Rcpp::NumericVector index_data; /**ymax = ymax; } /** - * @brief destructor + * @brief The destructor. */ virtual ~IndexDataInterface() {} - /** @brief get the ID of the interface base object + /** + * @brief Gets the ID of the interface base object. + * @return The ID. */ virtual uint32_t get_id() { return this->id; } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * data interface with index data. It also returns the ID, the rank of 1, the + * dimensions by printing ymax, followed by the data values themselves. This + * string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"data\",\n"; + ss << " \"type\": \"Index\",\n"; + ss << " \"id\": " << this->id << ",\n"; + ss << " \"rank\": " << 1 << ",\n"; + ss << " \"dimensions\": [" << this->ymax << "],\n"; + ss << " \"values\": ["; + for (R_xlen_t i = 0; i < index_data.size() - 1; i++) { + ss << index_data[i] << ", "; + } + ss << index_data[index_data.size() - 1] << "]\n"; + ss << "}"; + return ss.str(); + } #ifdef TMB_MODEL @@ -165,7 +351,8 @@ class IndexDataInterface : public DataInterfaceBase { } /** - *@brief function to add to TMB + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. */ virtual bool add_to_fims_tmb() { this->add_to_fims_tmb_internal(); diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_distribution.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_distribution.hpp new file mode 100644 index 000000000..37c5b2cfd --- /dev/null +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_distribution.hpp @@ -0,0 +1,679 @@ +/** + * @file rcpp_distribution.hpp + * @brief The Rcpp interface to declare different distributions, e.g., + * normal and log normal. Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ +#ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_DISTRIBUTION_HPP +#define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_DISTRIBUTION_HPP + +#include "../../../distributions/distributions.hpp" +#include "../../interface.hpp" +#include "rcpp_interface_base.hpp" + +/** + * @brief Rcpp interface that serves as the parent class for Rcpp distribution + * interfaces. This type should be inherited and not called from R directly. + */ +class DistributionsInterfaceBase : public FIMSRcppInterfaceBase { + public: + /** + * @brief The static ID of the DistributionsInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local ID of the DistributionsInterfaceBase object. + */ + uint32_t id_m; + /** + * @brief The unique ID for the variable map that points to a fims::Vector. + */ + std::vector key_m; + /** + * @brief The type of density input. The options are prior, re, or data. + */ + std::string input_type_m; + /** + * @brief The map associating the ID of the DistributionsInterfaceBase to the + DistributionsInterfaceBase objects. This is a live object, which is an + object that has been created and lives in memory. + */ + static std::map live_objects; + /** + * @brief The ID of the observed data object, which is set to -999. + */ + uint32_t interface_observed_data_id_m = -999; + + /** + * @brief The constructor. + */ + DistributionsInterfaceBase() { + this->id_m = DistributionsInterfaceBase::id_g++; + /* Create instance of map: key is id and value is pointer to + DistributionsInterfaceBase */ + DistributionsInterfaceBase::live_objects[this->id_m] = this; + FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); + } + + /** + * @brief The destructor. + */ + virtual ~DistributionsInterfaceBase() {} + + /** + * @brief Get the ID for the child distribution interface objects to inherit. + */ + virtual uint32_t get_id() = 0; + + /** + * @brief Sets pointers for data observations, random effects, or priors. + * + * @param input_type String that sets whether the distribution type is for priors, random effects, or data. + * @param ids Vector of unique ids for each linked parameter(s), derived + * value(s), or observed data vector. + */ + virtual bool set_distribution_links(std::string input_type, Rcpp::IntegerVector ids){ + return false; + } + + /** + * @brief Set the unique ID for the observed data object. + * + * @param observed_data_id Unique ID for the Observed Age Comp Data + * object + */ + virtual bool set_observed_data(int observed_data_id){ + return false; + } + + /** + * @brief A method for each child distribution interface object to inherit so + * each distribution can have an evaluate() function. + */ + virtual double evaluate() = 0; +}; +// static id of the DistributionsInterfaceBase object +uint32_t DistributionsInterfaceBase::id_g = 1; +// local id of the DistributionsInterfaceBase object map relating the ID of the +// DistributionsInterfaceBase to the DistributionsInterfaceBase objects +std::map DistributionsInterfaceBase::live_objects; + +/** + * @brief The Rcpp interface for Dnorm to instantiate from R: + * dnorm_ <- methods::new(DnormDistribution). + */ +class DnormDistributionsInterface : public DistributionsInterfaceBase { + public: + /** + * @brief Observed data. + */ + ParameterVector x; + /** + * @brief The expected values, which would be the mean of x for this + * distribution. + */ + ParameterVector expected_values; + /** + * @brief The uncertainty, which would be the standard deviation of x for the + * normal distribution. + */ + ParameterVector log_sd; + /** + * @brief The vector. TODO: document this more. + */ + Rcpp::NumericVector lpdf_vec; /**< The vector*/ + + /** + * @brief The constructor. + */ + DnormDistributionsInterface() : DistributionsInterfaceBase() {} + + /** + * @brief The destructor. + */ + virtual ~DnormDistributionsInterface() {} + + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ + virtual uint32_t get_id() { return this->id_m; } + + /** + * @brief Set the unique ID for the observed data object. + * @param observed_data_id Unique ID for the observed data object. + */ + virtual bool set_observed_data(int observed_data_id) { + this->interface_observed_data_id_m = observed_data_id; + return true; + } + + /** + * @brief Sets pointers for data observations, random effects, or priors. + * + * @param input_type String that sets whether the distribution type is for priors, random effects, or data. + * @param ids Vector of unique ids for each linked parameter(s), derived + * value(s), or observed data vector. + */ + virtual bool set_distribution_links(std::string input_type, Rcpp::IntegerVector ids){ + this->input_type_m = input_type; + this->key_m.resize(ids.size()); + for(int i=0; ikey_m[i] = ids[i]; + } + return true; + } + + /** + * @brief Evaluate normal probability density function (pdf). The natural log + * of the pdf is returned. + * @return The natural log of the probability density function (pdf) is + * returned. + */ + virtual double evaluate() { + fims_distributions::NormalLPDF dnorm; + dnorm.x.resize(this->x.size()); + dnorm.expected_values.resize(this->expected_values.size()); + dnorm.log_sd.resize(this->log_sd.size()); + for(size_t i=0; ix[i].initial_value_m; + } + for(size_t i=0; iexpected_values[i].initial_value_m; + } + for(size_t i=0; ilog_sd[i].initial_value_m; + } + return dnorm.evaluate(); + } + + /** + * @brief Extracts the derived quantities from `Information` to the Rcpp + * object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("DnormDistribution " + fims::to_string(this->id_m) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + fims_info::Information::density_components_iterator it; + + //search for density component in Information + it = info->density_components.find(this->id_m); + //if not found, just return + if (it == info->density_components.end()) { + FIMS_WARNING_LOG("DnormDistribution " + fims::to_string(this->id_m) + " not found in Information."); + return; + } else { + std::shared_ptr > dnorm = + std::dynamic_pointer_cast >(it->second); + this->lpdf_vec = Rcpp::NumericVector(dnorm->lpdf_vec.size()); + for(R_xlen_t i=0; i < this->lpdf_vec.size(); i++) { + this->lpdf_vec[i] = dnorm->lpdf_vec[i]; + } + } + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * distribution interface with a normal distribution. It also returns the ID + * and the natural log of the probability density function values themselves. + * This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"DnormDistribution\",\n"; + ss << " \"type\": \"normal\",\n"; + ss << " \"id\": " << this->id_m << ",\n"; + + ss << " \"density_component\": {\n"; + ss << " \"name\": \"lpdf_vec\",\n"; + ss << " \"values\":["; + if (this->lpdf_vec.size() == 0) { + ss << "]\n"; + } else { + for(R_xlen_t i=0; i < this->lpdf_vec.size() - 1; i++) { + ss << this->lpdf_vec[i] << ", "; + } + ss << this->lpdf_vec[this->lpdf_vec.size() - 1] << "]\n"; + } + ss << " }\n]"; + + return ss.str(); + } + + +#ifdef TMB_MODEL + + template + bool add_to_fims_tmb_internal() { + std::shared_ptr> info = + fims_info::Information::GetInstance(); + + std::shared_ptr> distribution = + std::make_shared>(); + + // interface to data/parameter value + + distribution->observed_data_id_m = + interface_observed_data_id_m; + distribution->input_type = this->input_type_m; + distribution->key.resize(this->key_m.size()); + for(size_t i=0; ikey_m.size(); i++){ + distribution->key[i] = this->key_m[i]; + } + distribution->id = this->id_m; + distribution->x.resize(this->x.size()); + for(size_t i=0; ix.size(); i++){ + distribution->x[i] = this->x[i].initial_value_m; + } + // set relative info + distribution->expected_values.resize(this->expected_values.size()); + for(size_t i=0; iexpected_values.size(); i++) { + distribution->expected_values[i] = this->expected_values[i].initial_value_m; + } + distribution->log_sd.resize(this->log_sd.size()); + for(size_t i=0; ilog_sd.size(); i++){ + distribution->log_sd[i] = this->log_sd[i].initial_value_m; + if(this->log_sd[i].estimated_m){ + info->RegisterParameterName("normal log_sd"); + info->RegisterParameter(distribution->log_sd[i]); + } + if (this->log_sd[i].is_random_effect_m) { + error("standard deviations cannot be set to random effects"); + } + } + info->variable_map[this->log_sd.id_m] = &(distribution)->log_sd; + + info->density_components[distribution->id] = distribution; + + return true; + } + + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ + virtual bool add_to_fims_tmb() { + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + + return true; + } + +#endif +}; + +/** + * @brief The Rcpp interface for Dlnorm to instantiate from R: + * dlnorm_ <- methods::new(DlnormDistribution). + */ +class DlnormDistributionsInterface : public DistributionsInterfaceBase { + public: + /** + * @brief Observed data. + */ + ParameterVector x; + /** + * @brief The expected values, which would be the mean of log(x) for this + * distribution. + */ + ParameterVector expected_values; + /** + * @brief The uncertainty, which would be the natural logarithm of the + standard deviation (sd) of log(x) for this distribution. The natural log + of the standard deviation is necessary because the exponential link + function is applied to the log transformed standard deviation to insure + standard deviation is positive. + */ + ParameterVector log_sd; + /** + * @brief The vector. TODO: document this more. + */ + Rcpp::NumericVector lpdf_vec; /**< The vector */ + + /** + * @brief The constructor. + */ + DlnormDistributionsInterface() : DistributionsInterfaceBase() {} + + /** + * @brief The destructor. + */ + virtual ~DlnormDistributionsInterface() {} + + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ + virtual uint32_t get_id() { return this->id_m; } + + /** + * @brief Set the unique ID for the observed data object. + * @param observed_data_id Unique ID for the observed data object. + */ + virtual bool set_observed_data(int observed_data_id) { + this->interface_observed_data_id_m = observed_data_id; + return true; + } + + /** + * @brief Sets pointers for data observations, random effects, or priors. + * + * @param input_type String that sets whether the distribution type is for priors, random effects, or data. + * @param ids Vector of unique ids for each linked parameter(s), derived + * value(s), or observed data vector. + */ + virtual bool set_distribution_links(std::string input_type, Rcpp::IntegerVector ids){ + this->input_type_m = input_type; + this->key_m.resize(ids.size()); + for(int i=0; ikey_m[i] = ids[i]; + } + return true; + } + + /** + * @brief Evaluate lognormal probability density function (pdf). The natural + * log of the pdf is returned. + * @return The natural log of the probability density function (pdf) is + * returned. + */ + virtual double evaluate() { + fims_distributions::LogNormalLPDF dlnorm; + dlnorm.x.resize(this->x.size()); + dlnorm.expected_values.resize(this->expected_values.size()); + dlnorm.log_sd.resize(this->log_sd.size()); + for(size_t i=0; ix[i].initial_value_m; + } + for(size_t i=0; iexpected_values[i].initial_value_m; + } + for(size_t i=0; ilog_sd[i].initial_value_m; + } + return dlnorm.evaluate(); + } + + /** + * @brief Extracts the derived quantities from `Information` to the Rcpp + * object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("LogNormalLPDF " + fims::to_string(this->id_m) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + fims_info::Information::density_components_iterator it; + + //search for density component in Information + it = info->density_components.find(this->id_m); + //if not found, just return + if (it == info->density_components.end()) { + FIMS_WARNING_LOG("LogNormalLPDF " + fims::to_string(this->id_m) + " not found in Information."); + return; + } else { + std::shared_ptr > dlnorm = + std::dynamic_pointer_cast >(it->second); + this->lpdf_vec = Rcpp::NumericVector(dlnorm->lpdf_vec.size()); + for(R_xlen_t i=0; i < this->lpdf_vec.size(); i++) { + this->lpdf_vec[i] = dlnorm->lpdf_vec[i]; + } + } + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * distribution interface with a log_normal distribution. It also returns the + * ID and the natural log of the probability density function values + * themselves. This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"LogNormalLPDF\",\n"; + ss << " \"type\": \"log_normal\",\n"; + ss << " \"id\": " << this->id_m << ",\n"; + + ss << " \"density_component\": {\n"; + ss << " \"name\": \"lpdf_vec\",\n"; + ss << " \"values\":["; + if (this->lpdf_vec.size() == 0) { + ss << "]\n"; + } else { + for(R_xlen_t i=0; i < this->lpdf_vec.size() - 1; i++) { + ss << this->lpdf_vec[i] << ", "; + } + ss << this->lpdf_vec[this->lpdf_vec.size() - 1] << "]\n"; + } + ss << " }\n]"; + + return ss.str(); + } + + + +#ifdef TMB_MODEL + + template + bool add_to_fims_tmb_internal() { + std::shared_ptr> info = + fims_info::Information::GetInstance(); + + std::shared_ptr> distribution = + std::make_shared>(); + + // set relative info + distribution->id = this->id_m; + distribution->observed_data_id_m = + interface_observed_data_id_m; + distribution->input_type = this->input_type_m; + distribution->key.resize(this->key_m.size()); + for(size_t i=0; ikey_m.size(); i++){ + distribution->key[i] = this->key_m[i]; + } + distribution->x.resize(this->x.size()); + for(size_t i=0; ix.size(); i++){ + distribution->x[i] = this->x[i].initial_value_m; + } + // set relative info + distribution->expected_values.resize(this->expected_values.size()); + for(size_t i=0; iexpected_values.size(); i++){ + distribution->expected_values[i] = this->expected_values[i].initial_value_m; + } + distribution->log_sd.resize(this->log_sd.size()); + for(size_t i=0; ilog_sd.size(); i++){ + distribution->log_sd[i] = this->log_sd[i].initial_value_m; + if(this->log_sd[i].estimated_m){ + info->RegisterParameterName("lognormal log_sd"); + info->RegisterParameter(distribution->log_sd[i]); + } + if (this->log_sd[i].is_random_effect_m) { + error("standard deviations cannot be set to random effects"); + } + } + info->variable_map[this->log_sd.id_m] = &(distribution)->log_sd; + + info->density_components[distribution->id] = distribution; + + return true; + } + + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ + virtual bool add_to_fims_tmb() { + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + + return true; + } + +#endif +}; + +/** + * @brief The Rcpp interface for Dmultinom to instantiate from R: + * dmultinom_ <- methods::new(DmultinomDistribution). + */ +class DmultinomDistributionsInterface : public DistributionsInterfaceBase { + public: + /** + * @brief Observed data, which should be a vector of length K of integers. + */ + ParameterVector x; + /** + * @brief The expected values, which should be a vector of length K where + * each value specifies the probability of class k. Note that, unlike in R, + * these probabilities must sum to 1.0. + */ + ParameterVector expected_values; + /** + * @brief The dimensions of the number of rows and columns of the + * multivariate dataset. + */ + Rcpp::NumericVector dims; + /** + * @brief The vector. TODO: document this more. + */ + Rcpp::NumericVector lpdf_vec; /**< The vector */ + + /** + * @brief The constructor. + */ + DmultinomDistributionsInterface() : DistributionsInterfaceBase() {} + + /** + * @brief The destructor. + */ + virtual ~DmultinomDistributionsInterface() {} + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ + virtual uint32_t get_id() { return this->id_m; } + + /** + * @brief Set the unique ID for the observed data object. + * @param observed_data_id Unique ID for the observed data object. + */ + virtual bool set_observed_data(int observed_data_id) { + this->interface_observed_data_id_m = observed_data_id; + return true; + } + + /** + * @brief Sets pointers for data observations, random effects, or priors. + * + * @param input_type String that sets whether the distribution type is for priors, random effects, or data. + * @param ids Vector of unique ids for each linked parameter(s), derived + * value(s), or observed data vector. + */ + virtual bool set_distribution_links(std::string input_type, Rcpp::IntegerVector ids){ + this->input_type_m = input_type; + this->key_m.resize(ids.size()); + for(int i=0; ikey_m[i] = ids[i]; + } + return true; + } + + /** + * @brief Evaluate multinomial probability density function (pdf). The log of + * the pdf is returned. + * @return The natural log of the probability density function (pdf) is + * returned. + */ + virtual double evaluate() { + fims_distributions::MultinomialLPMF dmultinom; + // Declare TMBVector in this scope + dmultinom.x.resize(this->x.size()); + dmultinom.expected_values.resize(this->expected_values.size()); + for(size_t i=0; ix[i].initial_value_m; + } + for(size_t i=0; iexpected_values[i].initial_value_m; + } + dmultinom.dims.resize(2); + dmultinom.dims[0] = this->dims[0]; + dmultinom.dims[1] = this->dims[1]; + return dmultinom.evaluate(); + } + +#ifdef TMB_MODEL + + template + bool add_to_fims_tmb_internal() { + std::shared_ptr> info = + fims_info::Information::GetInstance(); + + std::shared_ptr> distribution = + std::make_shared>(); + + distribution->id = this->id_m; + distribution->observed_data_id_m = + interface_observed_data_id_m; + distribution->input_type = this->input_type_m; + distribution->key.resize(this->key_m.size()); + for(size_t i=0; ikey_m.size(); i++){ + distribution->key[i] = this->key_m[i]; + } + distribution->x.resize(this->x.size()); + for(size_t i=0; ix.size(); i++){ + distribution->x[i] = this->x[i].initial_value_m; + } + // set relative info + distribution->expected_values.resize(this->expected_values.size()); + for(size_t i=0; iexpected_values.size(); i++){ + distribution->expected_values[i] = this->expected_values[i].initial_value_m; + } + if(this->dims.size()>0){ + distribution->dims.resize(2); + distribution->dims[0] = this->dims[0]; + distribution->dims[1] = this->dims[1]; + } + + info->density_components[distribution->id] = distribution; + + return true; + } + + virtual bool add_to_fims_tmb() { + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + this->add_to_fims_tmb_internal(); + + return true; + } + +#endif +}; +#endif diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_fleet.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_fleet.hpp index 227e9fb3d..543307123 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_fleet.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_fleet.hpp @@ -1,9 +1,10 @@ -/* - * File: rcpp_fleet.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. +/** + * @file rcpp_fleet.hpp + * @brief The Rcpp interface to declare fleets. Allows for the use of + * methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_FLEET_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_FLEET_HPP @@ -13,20 +14,29 @@ #include "rcpp_interface_base.hpp" /** - * @brief Rcpp interface that serves as the parent class for - * Rcpp fleet interfaces. This type should be inherited and not - * called from R directly. - * + * @brief Rcpp interface that serves as the parent class for Rcpp fleet + * interfaces. This type should be inherited and not called from R directly. */ class FleetInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the FleetInterfaceBase object */ - uint32_t id; /**< local id of the FleetInterfaceBase object */ - // live objects in C++ are objects that have been created and live in memory - static std::map live_objects; /**< -map relating the ID of the FleetInterfaceBase to the FleetInterfaceBase -objects */ + /** + * @brief The static id of the FleetInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local id of the FleetInterfaceBase object. + */ + uint32_t id; + /** + * @brief The map associating the IDs of FleetInterfaceBase to the objects. + * This is a live object, which is an object that has been created and lives + * in memory. + */ + static std::map live_objects; + /** + * @brief The constructor. + */ FleetInterfaceBase() { this->id = FleetInterfaceBase::id_g++; /* Create instance of map: key is id and value is pointer to @@ -35,160 +45,481 @@ objects */ FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); } + /** + * @brief The destructor. + */ virtual ~FleetInterfaceBase() {} - /** @brief get_id method for child fleet interface objects to inherit */ + /** + * @brief Get the ID for the child fleet interface objects to inherit. + */ virtual uint32_t get_id() = 0; }; - +// static id of the FleetInterfaceBase object uint32_t FleetInterfaceBase::id_g = 1; +// local id of the FleetInterfaceBase object map relating the ID of the +// FleetInterfaceBase to the FleetInterfaceBase objects std::map FleetInterfaceBase::live_objects; /** - * @brief Rcpp interface for Fleet as an S4 object. To instantiate - * from R: - * fleet <- new(Fleet) - * + * @brief The Rcpp interface for Fleet to instantiate from R: + * fleet <- methods::new(Fleet) */ class FleetInterface : public FleetInterfaceBase { - int interface_agecomp_likelihood_id_m = - -999; /**< id of agecomp likelihood component. The "interface_" prefix - indicates it belongs to the FleetInterface class, and the "_m" - postfix signifies that it's a member variable. */ - int interface_index_likelihood_id_m = - -999; /**< id of index likelihood component*/ - int interface_observed_agecomp_data_id_m = - -999; /**< id of observed agecomp data object*/ - int interface_observed_index_data_id_m = - -999; /**< id of observed index data object*/ - int interface_selectivity_id_m = -999; /**< id of selectivity component*/ + /** + * @brief The ID of the observed age-composition data object. + */ + int interface_observed_agecomp_data_id_m = -999; + /** + * @brief The ID of the observed length-composition data object. + */ + int interface_observed_lengthcomp_data_id_m = -999; + /** + * @brief The ID of the observed index data object. + */ + int interface_observed_index_data_id_m = -999; + /** + * @brief The ID of the selectivity object. + */ + int interface_selectivity_id_m = -999; - public: - bool is_survey = false; /**< whether this is a survey fleet */ - int nages; /**< number of ages in the fleet data*/ - int nyears; /**< number of years in the fleet data */ - double log_q; /**< log of catchability for the fleet*/ - Rcpp::NumericVector - log_Fmort; /**< log of fishing mortality rate for the fleet*/ - bool estimate_F = false; /**< whether the parameter F should be estimated*/ - bool estimate_q = false; /**< whether the parameter q should be estimated*/ - bool estimate_obs_error = false; /**< whether the parameter log_obs_error - should be estimated*/ - bool random_q = false; /**< whether q should be a random effect*/ - bool random_F = false; /**< whether F should be a random effect*/ - Rcpp::NumericVector log_obs_error; /**< the log of the observation error */ +public: + /** + * @brief The name of the fleet. + */ + std::string name = "NA"; + /** + * @brief Is this fleet a survey, then true. If the fleet is a fishery, then + * false, where false is the default. As of version 0.3.0, a fleet in FIMS + * cannot accommodate both landings and index data, and thus must be + * designated to be a fleet or a survey. This will be fixed in later + * versions. + */ + bool is_survey = false; + /** + * @brief The number of age bins in the fleet data. + */ + int nages; + /** + * @brief The number of length bins in the fleet data. + */ + int nlengths = 0; + /** + * @brief The number of years in the fleet data. + */ + int nyears; + /** + * @brief The natural log of the catchability parameter for this fleet. + */ + ParameterVector log_q; + /** + * @brief The vector of the natural log of fishing mortality rates for this + * fleet. + */ + ParameterVector log_Fmort; + /** + * @brief The vector of natural log of the expected index of abundance for the fleet. + */ + ParameterVector log_expected_index; + /** + * @brief The vector of expected catch-at-age in numbers for the fleet. + */ + ParameterVector proportion_catch_numbers_at_age; + /** + * @brief The vector of expected catch-at-length in numbers for the fleet. + */ + ParameterVector proportion_catch_numbers_at_length; + /** + * @brief The vector of conversions to go from age to length, i.e., the age-to-length-conversion matrix. + */ + ParameterVector age_length_conversion_matrix; + /** + * @brief Should catchability (q) be estimated? The default is false. + */ + bool estimate_q = false; + /** + * @brief Is catchability (q) a random effect? The default is false. + */ + bool random_q = false; + // derived quantities + /** + * @brief Derived catch-at-age in numbers. + */ + Rcpp::NumericVector derived_cnaa; + /** + * @brief Derived catch-at-length in numbers. + */ + Rcpp::NumericVector derived_cnal; + /** + * @brief Derived catch-at-age in weight (mt). + */ + Rcpp::NumericVector derived_cwaa; + /** + * @brief Derived index. + */ + Rcpp::NumericVector derived_index; + /** + * @brief Derived age compositions. + */ + Rcpp::NumericVector derived_age_composition; + /** + * @brief Derived length compositions. + */ + Rcpp::NumericVector derived_length_composition; + /** + * @brief The constructor. + */ FleetInterface() : FleetInterfaceBase() {} + /** + * @brief The destructor. + */ virtual ~FleetInterface() {} - /** @brief returns the id for the fleet interface */ - virtual uint32_t get_id() { return this->id; } - /** - * @brief Set the unique id for the Age Comp Likelihood object - * - * @param agecomp_likelihood_id Unique id for the Age Comp Likelihood object + * @brief Gets the ID of the interface base object. + * @return The ID. */ - void SetAgeCompLikelihood(int agecomp_likelihood_id) { - interface_agecomp_likelihood_id_m = agecomp_likelihood_id; - } + virtual uint32_t get_id() { return this->id; } /** - * @brief Set the unique id for the Index Likelihood object - * - * @param index_likelihood_id Unique id for the Index Likelihood object + * @brief Set the unique ID for the observed age-composition data object. + * @param observed_agecomp_data_id Unique ID for the observed data object. */ - void SetIndexLikelihood(int index_likelihood_id) { - interface_index_likelihood_id_m = index_likelihood_id; + void SetObservedAgeCompData(int observed_agecomp_data_id) { + interface_observed_agecomp_data_id_m = observed_agecomp_data_id; } /** - * @brief Set the unique id for the Observed Age Comp Data object - * - * @param observed_agecomp_data_id Unique id for the Observed Age Comp Data - * object + * @brief Set the unique ID for the observed length-composition data object. + * @param observed_lengthcomp_data_id Unique ID for the observed data object. */ - void SetObservedAgeCompData(int observed_agecomp_data_id) { - interface_observed_agecomp_data_id_m = observed_agecomp_data_id; + void SetObservedLengthCompData(int observed_lengthcomp_data_id) { + interface_observed_lengthcomp_data_id_m = observed_lengthcomp_data_id; } /** - * @brief Set the unique id for the Observed Index Data object - * - * @param observed_index_data_id Unique id for the Observed Index Data object + * @brief Set the unique ID for the observed index data object. + * @param observed_index_data_id Unique ID for the observed data object. */ void SetObservedIndexData(int observed_index_data_id) { interface_observed_index_data_id_m = observed_index_data_id; } /** - * @brief Set the unique id for the Selectivity object - * - * @param selectivity_id Unique id for the Selectivity object + * @brief Set the unique ID for the selectivity object. + * @param selectivity_id Unique ID for the observed object. */ void SetSelectivity(int selectivity_id) { interface_selectivity_id_m = selectivity_id; } + /** + * @brief Get the unique ID for the observed age-composition data object. + */ + int GetObservedAgeCompDataID() { + return interface_observed_agecomp_data_id_m; + } + + /** + * @brief Get the unique ID for the observed length-composition data + * object. + */ + int GetObservedLengthCompDataID() { + return interface_observed_lengthcomp_data_id_m; + } + + /** + * @brief Get the unique id for the observed index data object. + */ + int GetObservedIndexDataID() { + return interface_observed_index_data_id_m; + } + + /** + * @brief Extracts the derived quantities from `Information` to the Rcpp + * object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("Fleet " + fims::to_string(this->id) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + fims_info::Information::fleet_iterator it; + + it = info->fleets.find(this->id); + + if (it == info->fleets.end()) { + FIMS_WARNING_LOG("Fleet " + fims::to_string(this->id) + " not found in Information."); + return; + } else { + + std::shared_ptr > fleet = + std::dynamic_pointer_cast >(it->second); + + + for (size_t i = 0; i < this->log_Fmort.size(); i++) { + if (this->log_Fmort[i].estimated_m) { + this->log_Fmort[i].final_value_m = fleet->log_Fmort[i]; + } else { + this->log_Fmort[i].final_value_m = this->log_Fmort[i].initial_value_m; + } + } + + for (size_t i = 0; i < this->log_q.size(); i++) { + if (this->log_q[i].estimated_m) { + this->log_q[i].final_value_m = fleet->log_q[i]; + } else { + this->log_q[i].final_value_m = this->log_q[i].initial_value_m; + } + } + + this->derived_cnaa = Rcpp::NumericVector(fleet->catch_numbers_at_age.size()); + for (R_xlen_t i = 0; i < this->derived_cnaa.size(); i++) { + this->derived_cnaa[i] = fleet->catch_numbers_at_age[i]; + } + + this->derived_cnal = Rcpp::NumericVector(fleet->catch_numbers_at_length.size()); + for (R_xlen_t i = 0; i < this->derived_cnal.size(); i++) { + this->derived_cnal[i] = fleet->catch_numbers_at_length[i]; + } + + this->derived_cwaa = Rcpp::NumericVector(fleet->catch_weight_at_age.size()); + for (R_xlen_t i = 0; i < this->derived_cwaa.size(); i++) { + this->derived_cwaa[i] = fleet->catch_weight_at_age[i]; + } + + this->derived_age_composition = Rcpp::NumericVector(fleet->proportion_catch_numbers_at_age.size()); + for (R_xlen_t i = 0; i < this->derived_age_composition.size(); i++) { + this->derived_age_composition[i] = fleet->proportion_catch_numbers_at_age[i]; + } + + this->derived_length_composition = Rcpp::NumericVector(fleet->proportion_catch_numbers_at_length.size()); + for (R_xlen_t i = 0; i < this->derived_length_composition.size(); i++) { + this->derived_length_composition[i] = fleet->proportion_catch_numbers_at_length[i]; + } + + this->derived_index = Rcpp::NumericVector(fleet->expected_index.size()); + for (R_xlen_t i = 0; i < this->derived_index.size(); i++) { + this->derived_index[i] = fleet->expected_index[i]; + } + + } + + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * fleet interface. It returns the name and ID as well as all derived + * quantities and parameter estimates. This string is formatted for a json + * file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\" : \"Fleet\",\n"; + + ss << " \"type\" : \"fleet\",\n"; + ss << " \"tag\" : \"" << this->name << "\",\n"; + ss << " \"id\": " << this->id << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"log_Fmort\",\n"; + ss << " \"id\":" << this->log_Fmort.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\": " << this->log_Fmort << "\n},\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"log_q\",\n"; + ss << " \"id\":" << this->log_q.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\": " << this->log_q << "\n},\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"cnaa\",\n"; + ss << " \"values\":["; + if (this->derived_cnaa.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_cnaa.size() - 1; i++) { + ss << this->derived_cnaa[i] << ", "; + } + ss << this->derived_cnaa[this->derived_cnaa.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"cnal\",\n"; + ss << " \"values\":["; + if (this->derived_cnal.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_cnal.size() - 1; i++) { + ss << this->derived_cnal[i] << ", "; + } + ss << this->derived_cnal[this->derived_cnal.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"cwaa\",\n"; + ss << " \"values\":["; + if (this->derived_cwaa.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_cwaa.size() - 1; i++) { + ss << this->derived_cwaa[i] << ", "; + } + ss << this->derived_cwaa[this->derived_cwaa.size() - 1] << "]\n"; + } + ss << " },\n"; + + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"age_composition \",\n"; + ss << " \"values\":["; + if (this->derived_age_composition.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_age_composition.size() - 1; i++) { + ss << this->derived_age_composition[i] << ", "; + } + ss << this->derived_age_composition[this->derived_age_composition.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"length_composition \",\n"; + ss << " \"values\":["; + if (this->derived_length_composition.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_length_composition.size() - 1; i++) { + ss << this->derived_length_composition[i] << ", "; + } + ss << this->derived_length_composition[this->derived_length_composition.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"index \",\n"; + ss << " \"values\":["; + if (this->derived_index.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_index.size() - 1; i++) { + ss << this->derived_index[i] << ", "; + } + ss << this->derived_index[this->derived_index.size() - 1] << "]\n"; + } + ss << " },\n"; + + return ss.str(); + + } + + + #ifdef TMB_MODEL + template bool add_to_fims_tmb_internal() { std::shared_ptr > info = - fims_info::Information::GetInstance(); + fims_info::Information::GetInstance(); std::shared_ptr > fleet = - std::make_shared >(); + std::make_shared >(); // set relative info fleet->id = this->id; fleet->is_survey = this->is_survey; fleet->nages = this->nages; + fleet->nlengths = this->nlengths; fleet->nyears = this->nyears; - fleet->fleet_agecomp_likelihood_id_m = interface_agecomp_likelihood_id_m; - fleet->fleet_index_likelihood_id_m = interface_index_likelihood_id_m; fleet->fleet_observed_agecomp_data_id_m = - interface_observed_agecomp_data_id_m; + interface_observed_agecomp_data_id_m; + fleet->fleet_observed_lengthcomp_data_id_m = + interface_observed_lengthcomp_data_id_m; fleet->fleet_observed_index_data_id_m = interface_observed_index_data_id_m; fleet->fleet_selectivity_id_m = interface_selectivity_id_m; - fleet->log_obs_error.resize(this->log_obs_error.size()); - for (int i = 0; i < log_obs_error.size(); i++) { - fleet->log_obs_error[i] = this->log_obs_error[i]; - if (this->estimate_obs_error) { - info->RegisterParameter(fleet->log_obs_error[i]); - } - } + fleet->log_q.resize(this->log_q.size()); + for (size_t i = 0; i < this->log_q.size(); i++) { + fleet->log_q[i] = this->log_q[i].initial_value_m; - fleet->log_q = this->log_q; - if (this->estimate_q) { - if (this->random_q) { - info->RegisterRandomEffect(fleet->log_q); - } else { - info->RegisterParameter(fleet->log_q); + if (this->log_q[i].estimated_m) { + info->RegisterParameterName("log_q"); + if (this->log_q[i].is_random_effect_m) { + info->RegisterRandomEffect(fleet->log_q[i]); + } else { + info->RegisterParameter(fleet->log_q[i]); + } } } + fleet->log_Fmort.resize(this->log_Fmort.size()); - for (int i = 0; i < log_Fmort.size(); i++) { - fleet->log_Fmort[i] = this->log_Fmort[i]; + for (size_t i = 0; i < log_Fmort.size(); i++) { + fleet->log_Fmort[i] = this->log_Fmort[i].initial_value_m; - if (this->estimate_F) { - if (this->random_F) { + if (this->log_Fmort[i].estimated_m) { + info->RegisterParameterName("log_Fmort"); + if (this->log_Fmort[i].is_random_effect_m) { info->RegisterRandomEffect(fleet->log_Fmort[i]); } else { info->RegisterParameter(fleet->log_Fmort[i]); } } } + //add to variable_map + info->variable_map[this->log_Fmort.id_m] = &(fleet)->log_Fmort; + + //exp_catch + fleet->log_expected_index.resize(nyears); // assume index is for all ages. + info->variable_map[this->log_expected_index.id_m] = &(fleet)->log_expected_index; + fleet->proportion_catch_numbers_at_age.resize(nyears * nages); + info->variable_map[this->proportion_catch_numbers_at_age.id_m] = &(fleet)->proportion_catch_numbers_at_age; + + if(this->nlengths > 0){ + fleet->proportion_catch_numbers_at_length.resize(nyears * nlengths); + fleet->age_length_conversion_matrix.resize(nages * nlengths); + for (size_t i = 0; i < fleet->age_length_conversion_matrix.size(); i++){ + fleet->age_length_conversion_matrix[i] = this->age_length_conversion_matrix[i].initial_value_m; + + if (this->age_length_conversion_matrix[i].estimated_m) { + info->RegisterParameterName("age_length_conversion_matrix"); + if (this->age_length_conversion_matrix[i].is_random_effect_m) { + info->RegisterRandomEffect(fleet->age_length_conversion_matrix[i]); + } else { + info->RegisterParameter(fleet->age_length_conversion_matrix[i]); + } + } + } + info->variable_map[this->age_length_conversion_matrix.id_m] = &(fleet)->age_length_conversion_matrix; + info->variable_map[this->proportion_catch_numbers_at_length.id_m] = &(fleet)->proportion_catch_numbers_at_length; + } + // add to Information info->fleets[fleet->id] = fleet; return true; } - /** @brief this adds the values to the TMB model object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { + FIMS_INFO_LOG("adding Fleet object to TMB"); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_growth.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_growth.hpp index 8b60a2c4e..37220a77b 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_growth.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_growth.hpp @@ -1,9 +1,10 @@ -/* - * File: rcpp_growth.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. +/** + * @file rcpp_growth.hpp + * @brief The Rcpp interface to declare different types of growth, e.g., + * empirical weight-at-age data. Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_GROWTH_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_GROWTH_HPP @@ -12,24 +13,29 @@ #include "rcpp_interface_base.hpp" /** - * Growth Rcpp interface * - */ - -/** - * @brief Rcpp interface that serves as the parent class for - * Rcpp growth interfaces. This type should be inherited and not - * called from R directly. - * + * @brief Rcpp interface that serves as the parent class for Rcpp growth + * interfaces. This type should be inherited and not called from R directly. */ class GrowthInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the GrowthInterfaceBase object */ - uint32_t id; /**< local id of the GrowthInterfaceBase object */ - // live objects in C++ are objects that have been created and live in memory - static std::map live_objects; /**< -map relating the ID of the GrowthInterfaceBase to the GrowthInterfaceBase -objects */ + /** + * @brief The static id of the GrowthInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local id of the GrowthInterfaceBase object. + */ + uint32_t id; + /** + * @brief The map associating the IDs of GrowthInterfaceBase to the objects. + * This is a live object, which is an object that has been created and lives + * in memory. + */ + static std::map live_objects; + /** + * @brief The constructor. + */ GrowthInterfaceBase() { this->id = GrowthInterfaceBase::id_g++; /* Create instance of map: key is id and value is pointer to @@ -38,46 +44,74 @@ objects */ FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); } + /** + * @brief The destructor. + */ virtual ~GrowthInterfaceBase() {} - /** @brief get_id method for child growth interface objects to inherit */ + /** + * @brief Get the ID for the child growth interface objects to inherit. + */ virtual uint32_t get_id() = 0; - /** @brief evaluate method for child growth interface objects to inherit */ + /** + * @brief A method for each child growth interface object to inherit so + * each growth option can have an evaluate() function. + */ virtual double evaluate(double age) = 0; }; - +// static id of the GrowthInterfaceBase object uint32_t GrowthInterfaceBase::id_g = 1; +// local id of the GrowthInterfaceBase object map relating the ID of the +// GrowthInterfaceBase to the GrowthInterfaceBase objects std::map GrowthInterfaceBase::live_objects; /** - * @brief Rcpp interface for EWAAgrowth as an S4 object. To instantiate - * from R: - * ewaa <- new(EWAAgrowth) - * + * @brief Rcpp interface for EWAAgrowth to instantiate the object from R: + * ewaa <- methods::new(EWAAgrowth). Where, EWAA stands for empirical weight at + * age and growth is not actually estimated. */ class EWAAGrowthInterface : public GrowthInterfaceBase { public: - std::vector weights; /**< weights for each age class */ - std::vector ages; /**< ages for each age class */ - std::map ewaa; /**< map of ewaa values */ - - bool initialized = false; /**< boolean tracking if weights and ages -vectors have been set */ + /** + * @brief Weights (mt) for each age class. + */ + std::vector weights; + /** + * @brief Ages (years) for each age class. + */ + std::vector ages; + /** + * @brief A map of empirical weight-at-age values. TODO: describe this + * parameter better. + */ + std::map ewaa; + /** + * @brief Have weight and age vectors been set? The default is false. + */ + bool initialized = false; + /** + * @brief The constructor. + */ EWAAGrowthInterface() : GrowthInterfaceBase() {} + /** + * @brief The destructor. + */ virtual ~EWAAGrowthInterface() {} - /** @brief get the id of the GrowthInterfaceBase object */ + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ virtual uint32_t get_id() { return this->id; } /** - * @brief Create a map of input numeric vectors - * @param weights Type vector of weights - * @param ages Type vector of ages - * @return std::map - * + * @brief Create a map of input numeric vectors. + * @param weights Type vector of weights. + * @param ages Type vector of ages. + * @return std::map. */ inline std::map make_map(std::vector ages, std::vector weights) { @@ -88,9 +122,10 @@ vectors have been set */ return mymap; } - /** @brief Rcpp interface to the EWAAgrowth evaluate method - * you can call from R using - * ewaagrowth.evaluate(age) + /** + * @brief Evaluate the growth using empirical weight at age. + * @param age Age. TODO: Document this better. + * @details This can be called from R using ewaagrowth.evaluate(age). */ virtual double evaluate(double age) { fims_popdy::EWAAgrowth EWAAGrowth; @@ -108,15 +143,47 @@ vectors have been set */ EWAAGrowth.ewaa = this->ewaa; return EWAAGrowth.evaluate(age); } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * growth interface with empirical weight at age. It also returns the ID, the + * rank of 1, the dimensions, age bins, and the calculated values themselves. + * This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + ss << "\"module\" : {\n"; + ss << " \"name\": \"growth\",\n"; + ss << " \"type\" : \"EWAA\",\n"; + ss << " \"id\":" << this->id << ",\n"; + ss << " \"rank\": " << 1 << ",\n"; + ss << " \"dimensions\": [" << this->weights.size() << "],\n"; + + ss << " \"ages\": ["; + for (size_t i = 0; i < ages.size() - 1; i++) { + ss << ages[i] << ", "; + } + ss << ages[ages.size() - 1] << "],\n"; + + ss << " \"values\": ["; + for (size_t i = 0; i < weights.size() - 1; i++) { + ss << weights[i] << ", "; + } + ss << weights[weights.size() - 1] << "]\n"; + ss << "}"; + return ss.str(); + } + #ifdef TMB_MODEL template bool add_to_fims_tmb_internal() { std::shared_ptr > info = - fims_info::Information::GetInstance(); + fims_info::Information::GetInstance(); std::shared_ptr > ewaa_growth = - std::make_shared >(); + std::make_shared >(); // set relative info ewaa_growth->id = this->id; @@ -127,7 +194,10 @@ vectors have been set */ return true; } - /** @brief this adds the values to the TMB model object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp index d91b281ff..b10a66459 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp @@ -1,14 +1,15 @@ -/* - * File: rcpp_interface_base.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. - * +/** + * @file rcpp_interface_base.hpp + * @brief The Rcpp interface to declare objects that are used ubiquitously + * throughout the Rcpp interface, e.g., Parameters and ParameterVectors. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_INTERFACE_BASE_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_INTERFACE_BASE_HPP +#include #include #include @@ -20,57 +21,402 @@ #include /** - * @brief RcppInterface class that defines - * the interface between R and C++ for parameter types. + * @brief An Rcpp interface that defines the Parameter class. + * + * @details An Rcpp interface class that defines the interface between R and + * C++ for a parameter type. */ class Parameter { public: - double value_m; /**< initial value of the parameter*/ - double min_m = - std::numeric_limits::min(); /**< min value of the parameter*/ - double max_m = - std::numeric_limits::max(); /**< max value of the parameter*/ - bool is_random_effect_m = false; /**< Is the parameter a random effect - parameter? Default value is false.*/ - bool estimated_m = - false; /**< Is the parameter estimated? Default value is false.*/ + /** + * @brief The static ID of the Parameter object. + */ + static uint32_t id_g; + /** + * @brief The local ID of the Parameter object. + */ + uint32_t id_m; + /** + * @brief The initial value of the parameter. + */ + double initial_value_m = 0.0; + /** + * @brief The final value of the parameter. + */ + double final_value_m = 0.0; + /** + * @brief The minimum possible parameter value, where the default is negative + * infinity. + */ + double min_m = -std::numeric_limits::infinity(); + /** + * @brief The maximum possible parameter value, where the default is positive + * infinity. + */ + double max_m = std::numeric_limits::infinity(); + /** + * @brief Is the parameter a random effect? The default is false. + */ + bool is_random_effect_m = false; + /** + * @brief Should the parameter be estimated? The default is false. + */ + bool estimated_m = false; /** - * @brief Constructor for initializing Parameter. - * @details Inputs include value, min, max, estimated. + * @brief The constructor for initializing a parameter. */ Parameter(double value, double min, double max, bool estimated) - : value_m(value), min_m(min), max_m(max), estimated_m(estimated) {} + : id_m(Parameter::id_g++), initial_value_m(value), min_m(min), max_m(max), estimated_m(estimated) {} + + /** + * @brief The constructor for initializing a parameter. + */ + Parameter(const Parameter& other) : + id_m(other.id_m), initial_value_m(other.initial_value_m), + final_value_m(other.final_value_m), + min_m(other.min_m), max_m(other.max_m), + is_random_effect_m(other.is_random_effect_m), + estimated_m(other.estimated_m) {} + + /** + * @brief The constructor for initializing a parameter. + */ + Parameter& operator=(const Parameter& right) { + // Check for self-assignment! + if (this == &right) // Same object? + return *this; // Yes, so skip assignment, and just return *this. + this->id_m = right.id_m; + this->initial_value_m = right.initial_value_m; + this->estimated_m = right.estimated_m; + this->min_m = right.min_m; + this->max_m = right.max_m; + this->is_random_effect_m = right.is_random_effect_m; + return *this; + } + + /** - * @brief Constructor for initializing Parameter. - * @details Inputs include value. + * @brief The constructor for initializing a parameter. */ - Parameter(double value) { value_m = value; } + Parameter(double value) { + initial_value_m = value; + id_m = Parameter::id_g++; + } /** - * @brief Constructor for initializing Parameter. + * @brief The constructor for initializing a parameter. * @details Set value to 0 when there is no input value. */ - Parameter() { value_m = 0; } + Parameter() { + initial_value_m = 0; + id_m = Parameter::id_g++;} }; + /** + * @brief The unique ID for the variable map that points to a fims::Vector. + */ + uint32_t Parameter::id_g = 0; /** - *@brief Base class for all interface objects + * @brief Output for std::ostream& for a parameter. + * + * @param out The stream. + * @param p A parameter. + * @return std::ostream& + */ +std::ostream& operator<<(std::ostream& out, const Parameter& p) { + out << "{id:" << p.id_m << ",\nvalue:" << p.initial_value_m + << ",\nestimated_value:" << p.final_value_m << ",\nmin:" + << p.min_m << ",\nmax:" << p.max_m << ",\nestimated:" << p.estimated_m << "\n}"; + return out; +} + +/** + * @brief An Rcpp interface class that defines the ParameterVector class. + * + * @details An Rcpp interface class that defines the interface between R and + * C++ for a parameter vector type. + */ +class ParameterVector{ +public: + /** + * @brief The static ID of the Parameter object. + */ + static uint32_t id_g; + /** + * @brief Parameter storage. + */ + std::shared_ptr > storage_m; + /** + * @brief The local ID of the Parameter object. + */ + uint32_t id_m; + + /** + * @brief The constructor. + */ + ParameterVector(){ + this->id_m = ParameterVector::id_g++; + this->storage_m = std::make_shared >(); + this->storage_m->resize(1); //push_back(Rcpp::wrap(p)); + } + + /** + * @brief The constructor. + */ + ParameterVector(const ParameterVector& other) : + storage_m(other.storage_m), id_m(other.id_m) {} + + /** + * @brief The constructor. + */ + ParameterVector(size_t size ){ + this->id_m = ParameterVector::id_g++; + this->storage_m = std::make_shared >(); + this->storage_m->resize(size); + for (size_t i = 0; i < size; i++) { + storage_m->at(i) = Parameter(); + } + } + + /** + * @brief The constructor for initializing a parameter vector. + * @param x A numeric vector. + * @param size The number of elements to copy over. + */ + ParameterVector(Rcpp::NumericVector x, size_t size){ + this->id_m = ParameterVector::id_g++; + this->storage_m = std::make_shared >(); + this->resize(size); + for (size_t i = 0; i < size; i++) { + storage_m->at(i).initial_value_m = x[i]; + } + } + + /** + * @brief The constructor for initializing a parameter vector. + * @param v A vector of doubles. + */ + ParameterVector(const fims::Vector& v) { + this->id_m = ParameterVector::id_g++; + this->storage_m = std::make_shared >(); + this->storage_m->resize(v.size()); + for (size_t i = 0; i < v.size(); i++) { + storage_m->at(i).initial_value_m = v[i]; + } + } + + /** + * @brief Destroy the Parameter Vector object. + * + */ + virtual ~ParameterVector(){} + + /** + * @brief Gets the ID of the ParameterVector object. + */ + virtual uint32_t get_id() { return this->id_m; } + + /** + * @brief The accessor where the first index starts is zero. + * @param pos The position of the ParameterVector that you want returned. + */ + inline Parameter& operator[](size_t pos) { + return this->storage_m->at(pos); + } + + /** + * @brief The accessor where the first index starts at one. This function is + * for calling accessing from R. + * @param pos The position of the ParameterVector that you want returned. + */ + SEXP at(R_xlen_t pos){ + if (static_cast(pos) == 0 || + static_cast(pos) > this->storage_m->size()) { + Rcpp::Rcout << "ParameterVector: Index out of range.\n"; + FIMS_ERROR_LOG(fims::to_string(pos) + "!<" + fims::to_string(this->size())); + return NULL; + } + return Rcpp::wrap(this->storage_m->at(pos - 1)); + } + + /** + * @brief An internal accessor for calling a position of a ParameterVector + * from R. + * @param pos An integer specifying the position of the ParameterVector + * you want returned. The first position is one and the last position is + * the same as the size of the ParameterVector. + */ + Parameter& get(size_t pos) { + if (pos >= this->storage_m->size()) { + Rcpp::Rcout << "ParameterVector: Index out of range.\n"; + throw std::invalid_argument("ParameterVector: Index out of range"); + } + return (this->storage_m->at(pos)); + } + + /** + * @brief An internal setter for setting a position of a ParameterVector + * from R. + * @param pos An integer specifying the position of the ParameterVector + * you want to set. The first position is one and the last position is the + * same as the size of the ParameterVector. + * @param p A numeric value specifying the value to set position `pos` to + * in the ParameterVector. + */ + void set(size_t pos, const Parameter& p) { + this->storage_m->at(pos) = p; + } + + /** + * @brief Returns the size of a ParameterVector. + */ + size_t size() { + return this->storage_m->size(); + } + + /** + * @brief Resizes a ParameterVector to the desired length. + * @param size An integer specifying the desired length for the + * ParameterVector to be resized to. + */ + void resize(size_t size) { + this->storage_m->resize(size); + } + + /** + * @brief Sets all Parameters within a ParameterVector as estimable. + * + * @param estimable A boolean specifying if all Parameters within the + * ParameterVector should be estimated within the model. A value of true + * leads to all Parameters being estimated. + */ + void set_all_estimable(bool estimable){ + for (size_t i = 0; i < this->storage_m->size(); i++) { + storage_m->at(i).estimated_m = estimable; + } + } + + /** + * @brief Sets all Parameters within a ParameterVector as random effects. + * + * @param random A boolean specifying if all Parameters within the + * ParameterVector should be designated as random effects. A value of true + * leads to all Parameters being random effects. + */ + void set_all_random(bool random){ + for (size_t i = 0; i < this->storage_m->size(); i++) { + storage_m->at(i).is_random_effect_m = random; + } + } + + /** + * @brief Sets the value of all Parameters in the ParameterVector to the + * provided value. + * + * @param value A double specifying the value to set all Parameters to + * within the ParameterVector. + */ + void fill(double value){ + for (size_t i = 0; i < this->storage_m->size(); i++) { + storage_m->at(i).initial_value_m = value; + } + } + + /** + * @brief Assigns the given values to the minimum value of all elements in + * the vector. + * + * @param value The value to be assigned. + */ + void fill_min(double value){ + for (size_t i = 0; i < this->storage_m->size(); i++) { + storage_m->at(i).min_m = value; + } + } + + /** + * @brief Assigns the given values to the maximum value of all elements in + * the vector. + * + * @param value The value to be assigned. + */ + void fill_max(double value){ + for (size_t i = 0; i < this->storage_m->size(); i++) { + storage_m->at(i).max_m = value; + } + } + + /** + * @brief The printing methods for a ParameterVector. + * + */ + void show() { + Rcpp::Rcout << this->storage_m->data() << "\n"; + + for (size_t i = 0; i < this->storage_m->size(); i++) { + Rcpp::Rcout << storage_m->at(i) << " "; + } + } + +}; +uint32_t ParameterVector::id_g = 0; + +/** + * @brief Output for std::ostream& for a ParameterVector. + * + * @param out The stream. + * @param v A ParameterVector. + * @return std::ostream& + */ +std::ostream& operator<<(std::ostream& out, ParameterVector& v) { + out << "["; + size_t size = v.size(); + for (size_t i = 0; i < size - 1; i++) { + out << v[i] << ", "; + } + out << v[size - 1] << "]"; + return out; +} + +/** + *@brief Base class for all interface objects. */ class FIMSRcppInterfaceBase { - public: - /**< FIMS interface object vectors */ +public: + /** + * @brief Is the object already finalized? The default is false. + */ + bool finalized = false; + /** + * @brief FIMS interface object vectors. + */ static std::vector fims_interface_objects; - - /** @brief virtual method to inherit to add objects to the TMB model */ + /** + * @brief A virtual method to inherit to add objects to the TMB model. + */ virtual bool add_to_fims_tmb() { - std::cout << "fims_rcpp_interface_base::add_to_fims_tmb(): Not yet " + Rcpp::Rcout << "fims_rcpp_interface_base::add_to_fims_tmb(): Not yet " "implemented.\n"; return false; } + + /** + * @brief Extracts derived quantities back to the Rcpp interface object from + * the Information object. + */ + virtual void finalize() { + } + + /** + * @brief Convert the data to json representation for the output. + */ + virtual std::string to_json() { + return ""; + } }; std::vector - FIMSRcppInterfaceBase::fims_interface_objects; + FIMSRcppInterfaceBase::fims_interface_objects; #endif diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_lpdf.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_lpdf.hpp new file mode 100644 index 000000000..2e6a999d4 --- /dev/null +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_lpdf.hpp @@ -0,0 +1,71 @@ +/** + * @file rcpp_lpdf.hpp + * @brief The Rcpp interface to declare different probability density + * functions. Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + */ +#ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_LPDF_HPP +#define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_LPDF_HPP + +#include "../../../population_dynamics/recruitment/recruitment.hpp" +#include "rcpp_interface_base.hpp" + +/** + * @brief LPDFInterfaceBase class should be inherited to define different Rcpp + * interfaces for each possible log probability density function (pdf). + */ +class LPDFInterfaceBase : public FIMSRcppInterfaceBase { + public: + /** + * @brief The static ID of the LPDFInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local ID of the LPDFInterfaceBase object. + * TODO: think about why this is not id_m like other modules? + */ + uint32_t id; + /** + * @brief The map associating the ID of the LPDFInterfaceBase to the + LPDFInterfaceBase objects. This is a live object, which is an + object that has been created and lives in memory. + */ + static std::map live_objects; + + /** + * @brief The constructor. + */ + LPDFInterfaceBase() { + this->id = LPDFInterfaceBase::id_g++; + /* Create instance of map: key is id and value is pointer to + LPDFInterfaceBase */ + LPDFInterfaceBase::live_objects[this->id] = this; + LPDFInterfaceBase::fims_interface_objects.push_back(this); + } + + /** + * @brief The destructor. + */ + virtual ~LPDFInterfaceBase() {} + + /** + * @brief Get the ID for the child distribution interface objects to inherit. + */ + virtual uint32_t get_id() = 0; + + /** + * @brief A method for each child log probability density function (pdf) + * interface object to inherit so each pdf can have an evaluate() function. + * TODO: Think about why this is evaluate_lpdf instead of just evaluate? + */ + virtual double evaluate_lpdf() = 0; +}; +// static id of the LPDFInterfaceBase object +uint32_t LPDFInterfaceBase::id_g = 1; +// local id of the LPDFInterfaceBase object map relating the ID of the +// LPDFInterfaceBase to the LPDFInterfaceBase objects +std::map LPDFInterfaceBase::live_objects; + +#endif \ No newline at end of file diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp index 218ba5e1f..b3f5d04f3 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp @@ -1,11 +1,10 @@ -/* - * File: rcpp_maturity.hpp - * - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. - * +/** + * @file rcpp_maturity.hpp + * @brief The Rcpp interface to declare different maturity options, e.g., + * logistic. Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_MATURITY_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_MATURITY_HPP @@ -14,22 +13,29 @@ #include "rcpp_interface_base.hpp" /** - * maturity Rcpp interface - */ - -/** - * @brief MaturityInterfaceBase class should be inherited to - * define different Rcpp interfaces for each possible maturity function + * @brief Rcpp interface that serves as the parent class for Rcpp maturity + * interfaces. This type should be inherited and not called from R directly. */ class MaturityInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the recruitment interface base*/ - uint32_t id; /**< id of the recruitment interface base */ - // live objects in C++ are objects that have been created and live in memory - static std::map - live_objects; /**< map associating the ids of - MaturityInterfaceBase to the objects */ + /** + * @brief The static id of the MaturityInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local id of the MaturityInterfaceBase object. + */ + uint32_t id; + /** + * @brief The map associating the IDs of MaturityInterfaceBase to the objects. + * This is a live object, which is an object that has been created and lives + * in memory. + */ + static std::map live_objects; + /** + * @brief The constructor. + */ MaturityInterfaceBase() { this->id = MaturityInterfaceBase::id_g++; /* Create instance of map: key is id and value is pointer to @@ -38,76 +44,188 @@ class MaturityInterfaceBase : public FIMSRcppInterfaceBase { FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); } + /** + * @brief The destructor. + */ virtual ~MaturityInterfaceBase() {} - /** @brief get the ID of the interface base object + /** + * @brief Get the ID for the child maturity interface objects to inherit. */ virtual uint32_t get_id() = 0; /** - * @brief evaluate the function - * + * @brief A method for each child maturity interface object to inherit so + * each maturity option can have an evaluate() function. */ virtual double evaluate(double x) = 0; }; - +// static id of the MaturityInterfaceBase object uint32_t MaturityInterfaceBase::id_g = 1; +// local id of the MaturityInterfaceBase object map relating the ID of the +// MaturityInterfaceBase to the MaturityInterfaceBase objects std::map MaturityInterfaceBase::live_objects; /** - * @brief Rcpp interface for logistic maturity as an S4 object. To - * instantiate from R: logistic_maturity <- new(logistic_maturity) + * @brief Rcpp interface for logistic maturity to instantiate the object from R: + * logistic_maturity <- methods::new(logistic_maturity). */ class LogisticMaturityInterface : public MaturityInterfaceBase { - public: - Parameter - inflection_point; /**< the index value at which the response reaches .5 */ - Parameter slope; /**< the width of the curve at the inflection_point */ +public: + /** + * @brief The index value at which the response reaches 0.5. + */ + ParameterVector inflection_point; + /** + * @brief The width of the curve at the inflection point. + */ + ParameterVector slope; + /** + * @brief The constructor. + */ LogisticMaturityInterface() : MaturityInterfaceBase() {} + /** + * @brief The destructor. + */ virtual ~LogisticMaturityInterface() {} - /** @brief returns the id for the logistic maturity interface */ + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ virtual uint32_t get_id() { return this->id; } - /** @brief evaluate the logistic maturity function - * @param x The independent variable in the logistic function (e.g., age or + /** + * @brief Evaluate maturity using the logistic function. + * @param x The independent variable in the logistic function (e.g., age or * size in maturity). */ virtual double evaluate(double x) { fims_popdy::LogisticMaturity LogisticMat; - LogisticMat.inflection_point = this->inflection_point.value_m; - LogisticMat.slope = this->slope.value_m; + LogisticMat.inflection_point.resize(1); + LogisticMat.inflection_point[0] = this->inflection_point[0].initial_value_m; + LogisticMat.slope.resize(1); + LogisticMat.slope[0] = this->slope[0].initial_value_m; return LogisticMat.evaluate(x); } + /** + * @brief Extracts derived quantities back to the Rcpp interface object from + * the Information object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("Logistic Maturity " + fims::to_string(this->id) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + fims_info::Information::maturity_models_iterator it; + + //search for maturity in Information + it = info->maturity_models.find(this->id); + //if not found, just return + if (it == info->maturity_models.end()) { + FIMS_WARNING_LOG("Logistic Maturity " + fims::to_string(this->id) + " not found in Information."); + return; + } else { + std::shared_ptr > mat = + std::dynamic_pointer_cast >(it->second); + + for (size_t i = 0; i < inflection_point.size(); i++) { + if (this->inflection_point[i].estimated_m) { + this->inflection_point[i].final_value_m = mat->inflection_point[i]; + } else { + this->inflection_point[i].final_value_m = this->inflection_point[i].initial_value_m; + } + } + + for (size_t i = 0; i < slope.size(); i++) { + if (this->slope[i].estimated_m) { + this->slope[i].final_value_m = mat->slope[i]; + } else { + this->slope[i].final_value_m = this->slope[i].initial_value_m; + } + } + } + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * maturity interface with logistic maturity. It also returns the ID and the + * parameters. This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + ss << "\"module\" : {\n"; + ss << " \"name\": \"maturity\",\n"; + ss << " \"type\": \"logistic\",\n"; + ss << " \"id\": " << this->id << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"inflection_point\",\n"; + ss << " \"id\":" << this->inflection_point.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->inflection_point << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"slope\",\n"; + ss << " \"id\":" << this->slope.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->slope << ",\n"; + + ss << "}"; + + return ss.str(); + } + #ifdef TMB_MODEL template bool add_to_fims_tmb_internal() { std::shared_ptr > info = - fims_info::Information::GetInstance(); + fims_info::Information::GetInstance(); std::shared_ptr > maturity = - std::make_shared >(); + std::make_shared >(); // set relative info maturity->id = this->id; - maturity->inflection_point = this->inflection_point.value_m; - if (this->inflection_point.estimated_m) { - if (this->inflection_point.is_random_effect_m) { - info->RegisterRandomEffect(maturity->inflection_point); - } else { - info->RegisterParameter(maturity->inflection_point); + std::stringstream ss; + maturity->inflection_point.resize(this->inflection_point.size()); + for (size_t i = 0; i < this->inflection_point.size(); i++) { + maturity->inflection_point[i] = this->inflection_point[i].initial_value_m; + if (this->inflection_point[i].estimated_m) { + ss.str(""); + ss << "maturity.inflection_point." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->inflection_point[i].is_random_effect_m) { + info->RegisterRandomEffect(maturity->inflection_point[i]); + } else { + info->RegisterParameter(maturity->inflection_point[i]); + } } } - maturity->slope = this->slope.value_m; - if (this->slope.estimated_m) { - if (this->slope.is_random_effect_m) { - info->RegisterRandomEffect(maturity->slope); - } else { - info->RegisterParameter(maturity->slope); + + maturity->slope.resize(this->slope.size()); + for (size_t i = 0; i < this->slope.size(); i++) { + maturity->slope[i] = this->slope[i].initial_value_m; + if (this->slope[i].estimated_m) { + ss.str(""); + ss << "maturity.slope_" << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->slope[i].is_random_effect_m) { + info->RegisterRandomEffect(maturity->slope[i]); + } else { + info->RegisterParameter(maturity->slope[i]); + } } } @@ -117,9 +235,12 @@ class LogisticMaturityInterface : public MaturityInterfaceBase { return true; } - /** @brief this adds the parameter values and derivatives to the TMB model - * object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { + FIMS_INFO_LOG("adding Maturity object to TMB"); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_natural_mortality.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_natural_mortality.hpp index 260eafd97..50e6a0959 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_natural_mortality.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_natural_mortality.hpp @@ -1,11 +1,10 @@ -/* - * File: rcpp_natural_mortality.hpp - * - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. - * +/** + * @file rcpp_natural_mortality.hpp + * @brief The Rcpp interface to declare different types of natural mortality. + * Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_NATURAL_MORTALITY_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_NATURAL_MORTALITY_HPP diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_nll.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_nll.hpp deleted file mode 100644 index 405ef1631..000000000 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_nll.hpp +++ /dev/null @@ -1,49 +0,0 @@ -/* - * File: rcpp_nll.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE - * file for reuse information. - * - */ -#ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_NLL_HPP -#define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_NLL_HPP - -#include "../../../population_dynamics/recruitment/recruitment.hpp" -#include "rcpp_interface_base.hpp" - -/** - * @brief NLLInterfaceBase class should be inherited to - * define different Rcpp interfaces for each possible negative log-likelihood - * function - */ -class NLLInterfaceBase : public FIMSRcppInterfaceBase { - public: - static uint32_t id_g; /**< static id of the recruitment interface base*/ - uint32_t id; /**< id of the recruitment interface base */ - // live objects in C++ are objects that have been created and live in memory - static std::map live_objects; - /**< map associating the ids of NLLInterfaceBase to the objects */ - - NLLInterfaceBase() { - this->id = NLLInterfaceBase::id_g++; - /* Create instance of map: key is id and value is pointer to - NLLInterfaceBase */ - NLLInterfaceBase::live_objects[this->id] = this; - NLLInterfaceBase::fims_interface_objects.push_back(this); - } - - virtual ~NLLInterfaceBase() {} - - /** @brief get the ID of the interface base object - */ - virtual uint32_t get_id() = 0; - - /** @brief evaluate method for child nll interface objects to inherit */ - virtual double evaluate_nll() = 0; -}; - -uint32_t NLLInterfaceBase::id_g = 1; -std::map NLLInterfaceBase::live_objects; - -#endif \ No newline at end of file diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_population.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_population.hpp index 7ba946e37..8a1d15c54 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_population.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_population.hpp @@ -1,9 +1,10 @@ -/* - * File: rcpp_population.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE file - * for reuse information. +/** + * @file rcpp_population.hpp + * @brief The Rcpp interface to declare different types of populations. Allows + * for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_POPULATION_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_POPULATION_HPP @@ -12,22 +13,29 @@ #include "rcpp_interface_base.hpp" /** - * Population Rcpp interface - */ - -/** - * @brief PopulationInterfaceBase class should be inherited to - * define different Rcpp interfaces for each possible Population function + * @brief Rcpp interface that serves as the parent class for Rcpp population + * interfaces. This type should be inherited and not called from R directly. */ class PopulationInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the population interface base*/ - uint32_t id; /**< id of the population interface base */ - // live objects in C++ are objects that have been created and live in memory - static std::map - live_objects; /**< map associating the ids of PopulationInterfaceBase to - the objects */ + /** + * @brief The static id of the PopulationInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local id of the PopulationInterfaceBase object. + */ + uint32_t id; + /** + * @brief The map associating the IDs of PopulationInterfaceBase to the objects. + * This is a live object, which is an object that has been created and lives + * in memory. + */ + static std::map live_objects; + /** + * @brief The constructor. + */ PopulationInterfaceBase() { this->id = PopulationInterfaceBase::id_g++; /* Create instance of map: key is id and value is pointer to @@ -36,74 +44,322 @@ class PopulationInterfaceBase : public FIMSRcppInterfaceBase { PopulationInterfaceBase::fims_interface_objects.push_back(this); } + /** + * @brief The destructor. + */ virtual ~PopulationInterfaceBase() {} - /** @brief get_id method for child classes to inherit */ + /** + * @brief Get the ID for the child population interface objects to inherit. + */ virtual uint32_t get_id() = 0; }; - +// static id of the PopulationInterfaceBase object uint32_t PopulationInterfaceBase::id_g = 1; +// local id of the PopulationInterfaceBase object map relating the ID of the +// PopulationInterfaceBase to the PopulationInterfaceBase objects std::map - PopulationInterfaceBase::live_objects; + PopulationInterfaceBase::live_objects; /** - * @brief Rcpp interface for a new Population. To instantiate - * from R: - * population <- new(population) + * @brief Rcpp interface for a new Population to instantiate from R: + * population <- methods::new(population) */ class PopulationInterface : public PopulationInterfaceBase { public: - uint32_t nages; /**< number of ages */ - uint32_t nfleets; /**< number of fleets */ - uint32_t nseasons; /**< number of seasons */ - uint32_t nyears; /**< number of years */ - uint32_t maturity_id; /**< id of the maturity function*/ - uint32_t growth_id; /**< id of the growth function*/ - uint32_t recruitment_id; /**< id of the recruitment function*/ - Rcpp::NumericVector log_M; /**< log of the natural mortality of the stock*/ - Rcpp::NumericVector log_init_naa; /**id; } /** - * @brief Set the unique id for the Maturity object - * - * @param maturity_id Unique id for the Maturity object + * @brief Sets the unique ID for the Maturity object. + * @param maturity_id Unique ID for the Maturity object. */ void SetMaturity(uint32_t maturity_id) { this->maturity_id = maturity_id; } /** - * @brief Set the unique id for the growth object - * - * @param growth_id Unique id for the growth object + * @brief Set the unique ID for the growth object. + * @param growth_id Unique ID for the growth object. */ void SetGrowth(uint32_t growth_id) { this->growth_id = growth_id; } /** - * @brief Set the unique id for the Maturity object - * - * @param recruitment_id Unique id for the Maturity object + * @brief Set the unique ID for the recruitment object. + * @param recruitment_id Unique ID for the recruitment object. */ void SetRecruitment(uint32_t recruitment_id) { this->recruitment_id = recruitment_id; } - /** @brief evaluate the population function */ + /** + * @brief Evaluate the population function. + */ virtual void evaluate() { fims_popdy::Population population; return population.Evaluate(); } + /** + * @brief Extracts derived quantities back to the Rcpp interface object from + * the Information object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("Population " + fims::to_string(this->id) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + this->estimated_log_M = Rcpp::NumericVector(this->log_M.size()); + for (size_t i = 0; i < this->log_M.size(); i++) { + this->estimated_log_M[i] = this->log_M[i].initial_value_m; + } + + this->estimated_log_init_naa = Rcpp::NumericVector(this->log_init_naa.size()); + for (size_t i = 0; i < this->log_init_naa.size(); i++) { + this->estimated_log_init_naa[i] = this->log_init_naa[i].initial_value_m; + } + + fims_info::Information::population_iterator it; + + it = info->populations.find(this->id); + + std::shared_ptr > pop = + info->populations[this->id]; + it = info->populations.find(this->id); + if (it == info->populations.end()) { + FIMS_WARNING_LOG("Population " + fims::to_string(this->id) + " not found in Information."); + return; + } else { + if (this->estimated_log_M) { + for (size_t i = 0; i < this->log_M.size(); i++) { + this->estimated_log_M[i] = pop->log_M[i]; + } + } + + if (this->estimated_log_init_naa) { + for (size_t i = 0; i < this->log_init_naa.size(); i++) { + this->estimated_log_init_naa[i] = pop->log_init_naa[i]; + } + } + + this->derived_naa = Rcpp::NumericVector(pop->numbers_at_age.size()); + this->derived_ssb = Rcpp::NumericVector(pop->spawning_biomass.size()); + this->derived_biomass = Rcpp::NumericVector(pop->biomass.size()); + this->derived_recruitment = Rcpp::NumericVector(pop->expected_recruitment.size()); + + //set naa from Information/ + for (R_xlen_t i = 0; i < this->derived_naa.size(); i++) { + this->derived_naa[i] = pop->numbers_at_age[i]; + } + + //set ssb from Information/ + for (R_xlen_t i = 0; i < this->derived_ssb.size(); i++) { + this->derived_ssb[i] = pop->spawning_biomass[i]; + } + + //set biomass from Information + for (R_xlen_t i = 0; i < this->derived_biomass.size(); i++) { + this->derived_biomass[i] = pop->biomass[i]; + } + + //set recruitment from Information/ + for (R_xlen_t i = 0; i < this->derived_recruitment.size(); i++) { + this->derived_recruitment[i] = pop->expected_recruitment[i]; + } + + } + + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * population interface. It also returns the ID for each associated module + * and the values associated with that module. Then it returns several + * derived quantities. This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\" : \"Population\",\n"; + + ss << " \"type\" : \"population\",\n"; + ss << " \"tag\" : \"" << this->name << "\",\n"; + ss << " \"id\": " << this->id << ",\n"; + ss << " \"recruitment_id\": " << this->recruitment_id << ",\n"; + ss << " \"growth_id\": " << this->growth_id << ",\n"; + ss << " \"maturity_id\": " << this->maturity_id << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"log_M\",\n"; + ss << " \"id\":" << -999 << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\": " << this->log_M << "\n},\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"log_init_naa\",\n"; + ss << " \"id\":" << -999 << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->log_init_naa << " \n},\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"ssb\",\n"; + ss << " \"values\":["; + if (this->derived_ssb.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_ssb.size() - 1; i++) { + ss << this->derived_ssb[i] << ", "; + } + ss << this->derived_ssb[this->derived_ssb.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"naa\",\n"; + ss << " \"values\":["; + if (this->derived_naa.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_naa.size() - 1; i++) { + ss << this->derived_naa[i] << ", "; + } + ss << this->derived_naa[this->derived_naa.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"biomass\",\n"; + ss << " \"values\":["; + if (this->derived_biomass.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_biomass.size() - 1; i++) { + ss << this->derived_biomass[i] << ", "; + } + ss << this->derived_biomass[this->derived_biomass.size() - 1] << "]\n"; + } + ss << " },\n"; + + ss << " \"derived_quantity\": {\n"; + ss << " \"name\": \"recruitment\",\n"; + ss << " \"values\":["; + if (this->derived_recruitment.size() == 0) { + ss << "]\n"; + } else { + for (R_xlen_t i = 0; i < this->derived_recruitment.size() - 1; i++) { + ss << this->derived_recruitment[i] << ", "; + } + ss << this->derived_recruitment[this->derived_recruitment.size() - 1] << "]\n"; + } + ss << " }\n"; + + ss << "}"; + + return ss.str(); + } + + #ifdef TMB_MODEL template @@ -131,28 +387,29 @@ class PopulationInterface : public PopulationInterfaceBase { population->maturity_id = this->maturity_id; population->log_M.resize(this->log_M.size()); population->log_init_naa.resize(this->log_init_naa.size()); - for (int i = 0; i < log_M.size(); i++) { - population->log_M[i] = this->log_M[i]; - if (estimate_M) { - info->RegisterParameter(population->log_M[i]); + for (size_t i = 0; i < log_M.size(); i++) { + population->log_M[i] = this->log_M[i].initial_value_m; + if (this->log_M[i].estimated_m) { + info->RegisterParameterName("log_M"); + info->RegisterParameter(population->log_M[i]); } } + info->variable_map[this->log_M.id_m] = &(population)->log_M; - for (int i = 0; i < log_init_naa.size(); i++) { - population->log_init_naa[i] = this->log_init_naa[i]; - if (estimate_initNAA) { + for (size_t i = 0; i < log_init_naa.size(); i++) { + population->log_init_naa[i] = this->log_init_naa[i].initial_value_m; + if (this->log_init_naa[i].estimated_m) { + info->RegisterParameterName("log_init_naa"); info->RegisterParameter(population->log_init_naa[i]); } } + info->variable_map[this->log_init_naa.id_m] = &(population)->log_init_naa; for (int i = 0; i < ages.size(); i++) { population->ages[i] = this->ages[i]; } - for (int i = 0; i < proportion_female.size(); i++) { - population->proportion_female[i] = this->proportion_female[i]; - if (estimate_prop_female) { - info->RegisterParameter(population->proportion_female[i]); - } - } + + population->numbers_at_age.resize((nyears + 1) * nages); + info->variable_map[this->numbers_at_age.id_m] = &(population)->numbers_at_age; // add to Information info->populations[population->id] = population; @@ -160,9 +417,12 @@ class PopulationInterface : public PopulationInterfaceBase { return true; } - /** @brief this adds the parameter values and derivatives to the TMB model - * object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { + FIMS_INFO_LOG("adding Population object to TMB"); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_recruitment.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_recruitment.hpp index e60c13751..e75e2ffc7 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_recruitment.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_recruitment.hpp @@ -1,10 +1,11 @@ -/* - * File: rcpp_recruitment.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE - * file for reuse information. - * +/** + * @file rcpp_recruitment.hpp + * @brief The Rcpp interface to declare different types of recruitment, e.g., + * Beverton--Holt stock--recruitment relationship. Allows for the use of + * methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_RECRUITMENT_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_RECRUITMENT_HPP @@ -13,26 +14,29 @@ #include "rcpp_interface_base.hpp" /** - * Recruitment Rcpp interface - */ - -/** - * @brief RecruitmentInterfaceBase class should be inherited to - * define different Rcpp interfaces for each possible Recruitment function + * @brief Rcpp interface that serves as the parent class for Rcpp recruitment + * interfaces. This type should be inherited and not called from R directly. */ class RecruitmentInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the recruitment interface base*/ - uint32_t id; /**< id of the recruitment interface base */ - // live objects in C++ are objects that have been created and live in memory + /** + * @brief The static id of the RecruitmentInterfaceBase object. + */ + static uint32_t id_g; + /** + * @brief The local id of the RecruitmentInterfaceBase object. + */ + uint32_t id; + /** + * @brief The map associating the IDs of RecruitmentInterfaceBase to the + * objects. This is a live object, which is an object that has been created + * and lives in memory. + */ static std::map live_objects; - /**< map associating the ids of RecruitmentInterfaceBase to the objects */ - - // static std::vector log_recruit_devs; /**< vector of log recruitment - // deviations*/ - // static bool constrain_deviations; /**< whether or not the rec devs are - // constrained*/ + /** + * @brief The constructor. + */ RecruitmentInterfaceBase() { this->id = RecruitmentInterfaceBase::id_g++; /* Create instance of map: key is id and value is pointer to @@ -41,75 +45,192 @@ class RecruitmentInterfaceBase : public FIMSRcppInterfaceBase { FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); } + /** + * @brief The destructor. + */ virtual ~RecruitmentInterfaceBase() {} - /** @brief get the ID of the interface base object + /** + * @brief Get the ID for the child recruitment interface objects to inherit. */ virtual uint32_t get_id() = 0; - /** @brief evaluate method for child recruitment interface objects to inherit - */ - virtual double evaluate(double spawners, double ssbzero) = 0; - /** - * @brief evaluate recruitment nll - * - * @return double + * @brief A method for each child recruitment interface object to inherit so + * each recruitment option can have an evaluate() function. */ - virtual double evaluate_nll() = 0; + virtual double evaluate(double spawners, double ssbzero) = 0; }; - +// static id of the RecruitmentInterfaceBase object uint32_t RecruitmentInterfaceBase::id_g = 1; +// local id of the RecruitmentInterfaceBase object map relating the ID of the +// RecruitmentInterfaceBase to the RecruitmentInterfaceBase objects std::map RecruitmentInterfaceBase::live_objects; /** - * @brief Rcpp interface for Beverton-Holt as an S4 object. To instantiate - * from R: - * beverton_holt <- new(beverton_holt) + * @brief Rcpp interface for Beverton--Holt to instantiate from R: + * beverton_holt <- methods::new(beverton_holt). */ class BevertonHoltRecruitmentInterface : public RecruitmentInterfaceBase { public: - Parameter logit_steep; /**< steepness or the productivity of the stock*/ - Parameter log_rzero; /**< recruitment at unfished biomass */ - Parameter - log_sigma_recruit; /**< the log of the stock recruit standard deviation */ - Rcpp::NumericVector log_devs; /**< log recruitment deviations*/ - bool estimate_log_devs = false; /**< boolean describing whether to estimate */ + /** + * @brief The logistic transformation of steepness (h; productivity of the + * population), where the parameter is transformed to constrain it between + * 0.2 and 1.0. + */ + ParameterVector logit_steep; + /** + * @brief The natural log of recruitment at unfished biomass. + */ + ParameterVector log_rzero; + /** + * @brief The natural log of recruitment deviations. + */ + ParameterVector log_devs; + /** + * @brief Should the natural log of recruitment deviations be estimated? The + * default is false. + */ + bool estimate_log_devs = false; + /** + * @brief The estimate of the logit transformation of steepness. + */ + double estimated_logit_steep; + /** + * @brief The estimate of the natural log of recruitment at unfished biomass. + */ + double estimated_log_rzero; + /** + * @brief The estimates of the natural log of recruitment deviations. + */ + Rcpp::NumericVector estimated_log_devs; + /** + * @brief The constructor. + */ BevertonHoltRecruitmentInterface() : RecruitmentInterfaceBase() {} + /** + * @brief The destructor. + */ virtual ~BevertonHoltRecruitmentInterface() {} + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ virtual uint32_t get_id() { return this->id; } + /** + * @brief Evaluate recruitment using the Beverton--Holt stock--recruitment + * relationship. + * @param spawners Spawning biomass per time step. + * @param ssbzero The biomass at unfished levels. + * TODO: Change to sbzero if continuing to use acronyms. + */ virtual double evaluate(double spawners, double ssbzero) { fims_popdy::SRBevertonHolt BevHolt; - - BevHolt.logit_steep = this->logit_steep.value_m; - if (this->logit_steep.value_m == 1.0) { + BevHolt.logit_steep.resize(1); + BevHolt.logit_steep[0] = this->logit_steep[0].initial_value_m; + if (this->logit_steep[0].initial_value_m == 1.0) { warning( - "Steepness is subject to a logit transformation, so its value is " - "0.7848469. Fixing it at 1.0 is not currently possible."); + "Steepness is subject to a logit transformation. " + "Fixing it at 1.0 is not currently possible." + ); } - - BevHolt.log_rzero = this->log_rzero.value_m; + BevHolt.log_rzero.resize(1); + BevHolt.log_rzero[0] = this->log_rzero[0].initial_value_m; return BevHolt.evaluate(spawners, ssbzero); } - virtual double evaluate_nll() { - fims_popdy::SRBevertonHolt NLL; + /** + * @brief Extracts derived quantities back to the Rcpp interface object from + * the Information object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("Beverton-Holt Recruitment " + fims::to_string(this->id) + " has been finalized already."); + } - NLL.log_sigma_recruit = this->log_sigma_recruit.value_m; - NLL.log_recruit_devs.resize(log_devs.size()); // Vector from TMB - for (int i = 0; i < log_devs.size(); i++) { - NLL.log_recruit_devs[i] = log_devs[i]; + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + fims_info::Information::recruitment_models_iterator it; + + it = info->recruitment_models.find(this->id); + + if (it == info->recruitment_models.end()) { + FIMS_WARNING_LOG("Beverton-Holt Recruitment " + fims::to_string(this->id) + " not found in Information."); + return; + } else { + std::shared_ptr > recr = + std::dynamic_pointer_cast >(it->second); + + for (size_t i = 0; i < this->logit_steep.size(); i++) { + if (this->logit_steep[i].estimated_m) { + this->logit_steep[i].final_value_m = recr->logit_steep[i]; + } else { + this->logit_steep[i].final_value_m = this->logit_steep[i].initial_value_m; + } + } + + for (size_t i = 0; i < log_rzero.size(); i++) { + if (log_rzero[i].estimated_m) { + this->log_rzero[i].final_value_m = recr->log_rzero[i]; + } else { + this->log_rzero[i].final_value_m = this->log_rzero[i].initial_value_m; + } + } + + for (R_xlen_t i = 0; i < this->estimated_log_devs.size(); i++) { + if (this->log_devs[i].estimated_m) { + this->log_devs[i].final_value_m = recr->log_recruit_devs[i]; + } else { + this->log_devs[i].final_value_m = this->log_devs[i].initial_value_m; + } + } } - RECRUITMENT_LOG << "Log recruit devs being passed to C++ are " << log_devs - << std::endl; - NLL.estimate_log_recruit_devs = this->estimate_log_devs; - return NLL.evaluate_nll(); + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * recruitment interface with Beverton--Holt stock--recruitment relationship. + * It also returns the ID and the parameters. This string is formatted for a + * json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"recruitment\",\n"; + ss << " \"type\": \"Beverton--Holt\",\n"; + ss << " \"id\": " << this->id << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"logit_steep\",\n"; + ss << " \"id\":" << this->logit_steep.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->logit_steep << ",\n},\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"log_rzero\",\n"; + ss << " \"id\":" << this->log_rzero.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->log_rzero << ",\n },\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"log_devs\",\n"; + ss << " \"id\":" << this->log_devs.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->log_devs << ",\n },\n"; + + return ss.str(); } #ifdef TMB_MODEL @@ -117,50 +238,59 @@ class BevertonHoltRecruitmentInterface : public RecruitmentInterfaceBase { template bool add_to_fims_tmb_internal() { std::shared_ptr > info = - fims_info::Information::GetInstance(); + fims_info::Information::GetInstance(); std::shared_ptr > recruitment = - std::make_shared >(); + std::make_shared >(); // set relative info recruitment->id = this->id; - recruitment->logit_steep = this->logit_steep.value_m; - if (this->logit_steep.estimated_m) { - if (this->logit_steep.is_random_effect_m) { - info->RegisterRandomEffect(recruitment->logit_steep); - } else { - info->RegisterParameter(recruitment->logit_steep); - } - } - recruitment->log_rzero = this->log_rzero.value_m; - if (this->log_rzero.estimated_m) { - if (this->log_rzero.is_random_effect_m) { - info->RegisterRandomEffect(recruitment->log_rzero); - } else { - info->RegisterParameter(recruitment->log_rzero); + //set logit_steep + recruitment->logit_steep.resize(this->logit_steep.size()); + for (size_t i = 0; i < this->logit_steep.size(); i++) { + recruitment->logit_steep[i] = this->logit_steep[i].initial_value_m; + + if (this->logit_steep[i].estimated_m) { + info->RegisterParameterName("logit_steep"); + if (this->logit_steep[i].is_random_effect_m) { + info->RegisterRandomEffect(recruitment->logit_steep[i]); + } else { + info->RegisterParameter(recruitment->logit_steep[i]); + } } + } - recruitment->log_sigma_recruit = this->log_sigma_recruit.value_m; - if (this->log_sigma_recruit.estimated_m) { - if (this->log_sigma_recruit.is_random_effect_m) { - info->RegisterRandomEffect(recruitment->log_sigma_recruit); - } else { - info->RegisterParameter(recruitment->log_sigma_recruit); + + info->variable_map[this->logit_steep.id_m] = &(recruitment)->logit_steep; + + //set log_rzero + recruitment->log_rzero.resize(this->log_rzero.size()); + for (size_t i = 0; i < this->log_rzero.size(); i++) { + recruitment->log_rzero[i] = this->log_rzero[i].initial_value_m; + + if (this->log_rzero[i].estimated_m) { + info->RegisterParameterName("log_rzero"); + if (this->log_rzero[i].is_random_effect_m) { + info->RegisterRandomEffect(recruitment->log_rzero[i]); + } else { + info->RegisterParameter(recruitment->log_rzero[i]); + } } } + info->variable_map[this->log_rzero.id_m] = &(recruitment)->log_rzero; + + //set log_recruit_devs recruitment->log_recruit_devs.resize(this->log_devs.size()); - if (this->estimate_log_devs) { - for (size_t i = 0; i < recruitment->log_recruit_devs.size(); i++) { - recruitment->log_recruit_devs[i] = this->log_devs[i]; + for (size_t i = 0; i < this->log_devs.size(); i++) { + recruitment->log_recruit_devs[i] = this->log_devs[i].initial_value_m; + if (this->log_devs[i].estimated_m) { info->RegisterParameter(recruitment->log_recruit_devs[i]); - } - } else { - recruitment->estimate_log_recruit_devs = estimate_log_devs; - for (size_t i = 0; i < recruitment->log_recruit_devs.size(); i++) { - recruitment->log_recruit_devs[i] = this->log_devs[i]; + } else { + recruitment->estimate_log_recruit_devs = false; } } + info->variable_map[this->log_devs.id_m] = &(recruitment)->log_recruit_devs; // add to Information info->recruitment_models[recruitment->id] = recruitment; @@ -168,9 +298,12 @@ class BevertonHoltRecruitmentInterface : public RecruitmentInterfaceBase { return true; } - /** @brief this adds the parameter values and derivatives to the TMB model - * object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { + FIMS_INFO_LOG("adding Recruitment object to TMB"); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_selectivity.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_selectivity.hpp index 130f177fc..1ea8a3277 100644 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_selectivity.hpp +++ b/inst/include/interface/rcpp/rcpp_objects/rcpp_selectivity.hpp @@ -1,10 +1,10 @@ -/* - * File: rcpp_selectivity.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE - * file for reuse information. - * +/** + * @file rcpp_selectivity.hpp + * @brief The Rcpp interface to declare different types of selectivity, e.g., + * logistic and double logistic. Allows for the use of methods::new() in R. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_SELECTIVITY_HPP #define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_SELECTIVITY_HPP @@ -13,22 +13,29 @@ #include "rcpp_interface_base.hpp" /** - * Selectivity Rcpp interface - */ - -/** - * @brief SelectivityInterfaceBase class should be inherited to - * define different Rcpp interfaces for each possible Selectivity function + * @brief Rcpp interface that serves as the parent class for Rcpp selectivity + * interfaces. This type should be inherited and not called from R directly. */ class SelectivityInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the recruitment interface base*/ - uint32_t id; /**< id of the recruitment interface base */ - // live objects in C++ are objects that have been created and live in memory - static std::map - live_objects; /**< map associating the ids of - SelectivityInterfaceBase to the objects */ + /** + * @brief The static id of the SelectivityInterfaceBase. + */ + static uint32_t id_g; + /** + * @brief The local id of the SelectivityInterfaceBase object. + */ + uint32_t id; + /** + * @brief The map associating the IDs of SelectivityInterfaceBase to the + * objects. This is a live object, which is an object that has been created + * and lives in memory. + */ + static std::map live_objects; + /** + * @brief The constructor. + */ SelectivityInterfaceBase() { this->id = SelectivityInterfaceBase::id_g++; /* Create instance of map: key is id and value is pointer to @@ -37,79 +44,195 @@ class SelectivityInterfaceBase : public FIMSRcppInterfaceBase { FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); } + /** + * @brief The destructor. + */ virtual ~SelectivityInterfaceBase() {} - /** @brief get the ID of the interface base object + /** + * @brief Get the ID for the child selectivity interface objects to inherit. */ virtual uint32_t get_id() = 0; /** - * @brief evaluate the function - * + * @brief A method for each child selectivity interface object to inherit so + * each selectivity option can have an evaluate() function. */ virtual double evaluate(double x) = 0; }; - +// static id of the SelectivityInterfaceBase object uint32_t SelectivityInterfaceBase::id_g = 1; +// local id of the SelectivityInterfaceBase object map relating the ID of the +// SelectivityInterfaceBase to the SelectivityInterfaceBase objects std::map - SelectivityInterfaceBase::live_objects; + SelectivityInterfaceBase::live_objects; /** - * @brief Rcpp interface for logistic selectivity as an S4 object. To - * instantiate from R: logistic_selectivity <- new(logistic_selectivity) + * @brief Rcpp interface for logistic selectivity to instantiate the object + * from R: + * logistic_selectivity <- methods::new(logistic_selectivity). */ class LogisticSelectivityInterface : public SelectivityInterfaceBase { public: - Parameter - inflection_point; /**< the index value at which the response reaches .5 */ - Parameter slope; /**< the width of the curve at the inflection_point */ + /** + * @brief The index value at which the response reaches 0.5. + */ + ParameterVector inflection_point; + /** + * @brief The width of the curve at the inflection point. + */ + ParameterVector slope; + /** + * @brief The constructor. + */ LogisticSelectivityInterface() : SelectivityInterfaceBase() {} + /** + * @brief The destructor. + */ virtual ~LogisticSelectivityInterface() {} - /** @brief returns the id for the logistic selectivity interface */ + /** + * @brief Gets the ID of the interface base object. + * @return The ID. + */ virtual uint32_t get_id() { return this->id; } - /** @brief evaluate the logistic selectivity function - * @param x The independent variable in the logistic function (e.g., age or + /** + * @brief Evaluate selectivity using the logistic function. + * @param x The independent variable in the logistic function (e.g., age or * size in selectivity). */ virtual double evaluate(double x) { fims_popdy::LogisticSelectivity LogisticSel; - LogisticSel.inflection_point = this->inflection_point.value_m; - LogisticSel.slope = this->slope.value_m; + LogisticSel.inflection_point.resize(1); + LogisticSel.inflection_point[0] = this->inflection_point[0].initial_value_m; + LogisticSel.slope.resize(1); + LogisticSel.slope[0] = this->slope[0].initial_value_m; return LogisticSel.evaluate(x); } + /** + * @brief Extracts derived quantities back to the Rcpp interface object from + * the Information object. + */ + virtual void finalize() { + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("Logistic Selectivity " + fims::to_string(this->id) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + fims_info::Information::selectivity_models_iterator it; + + //search for maturity in Information + it = info->selectivity_models.find(this->id); + //if not found, just return + if (it == info->selectivity_models.end()) { + FIMS_WARNING_LOG("Logistic Selectivity " + fims::to_string(this->id) + " not found in Information."); + return; + } else { + std::shared_ptr > sel = + std::dynamic_pointer_cast >(it->second); + + for (size_t i = 0; i < inflection_point.size(); i++) { + if (this->inflection_point[i].estimated_m) { + this->inflection_point[i].final_value_m = sel->inflection_point[i]; + } else { + this->inflection_point[i].final_value_m = this->inflection_point[i].initial_value_m; + } + } + + for (size_t i = 0; i < slope.size(); i++) { + if (this->slope[i].estimated_m) { + this->slope[i].final_value_m = sel->slope[i]; + } else { + this->slope[i].final_value_m = this->slope[i].initial_value_m; + } + } + } + } + + /** + * @brief Converts the data to json representation for the output. + * @return A string is returned specifying that the module relates to the + * selectivity interface with logistic selectivity. It also returns the ID + * and the parameters. This string is formatted for a json file. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\":\"selectivity\",\n"; + ss << " \"type\": \"Logistic\",\n"; + ss << " \"id\": " << this->id << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"inflection_point\",\n"; + ss << " \"id\":" << this->inflection_point.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->inflection_point << ",\n },\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"slope\",\n"; + ss << " \"id\":" << this->slope.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->slope << ",\n}\n"; + + ss << "}"; + + return ss.str(); + } + + #ifdef TMB_MODEL template bool add_to_fims_tmb_internal() { std::shared_ptr > info = - fims_info::Information::GetInstance(); + fims_info::Information::GetInstance(); std::shared_ptr > selectivity = - std::make_shared >(); - + std::make_shared >(); + std::stringstream ss; // set relative info selectivity->id = this->id; - selectivity->inflection_point = this->inflection_point.value_m; - if (this->inflection_point.estimated_m) { - if (this->inflection_point.is_random_effect_m) { - info->RegisterRandomEffect(selectivity->inflection_point); - } else { - info->RegisterParameter(selectivity->inflection_point); + selectivity->inflection_point.resize(this->inflection_point.size()); + for (size_t i = 0; i < this->inflection_point.size(); i++) { + selectivity->inflection_point[i] = this->inflection_point[i].initial_value_m; + if (this->inflection_point[i].estimated_m) { + ss.str(""); + ss << "selectivity.inflection_point." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->inflection_point[i].is_random_effect_m) { + info->RegisterRandomEffect(selectivity->inflection_point[i]); + } else { + info->RegisterParameter(selectivity->inflection_point[i]); + } + } } - } - selectivity->slope = this->slope.value_m; - if (this->slope.estimated_m) { - if (this->slope.is_random_effect_m) { - info->RegisterRandomEffect(selectivity->slope); - } else { - info->RegisterParameter(selectivity->slope); + + info->variable_map[this->inflection_point.id_m] = &(selectivity)->inflection_point; + selectivity->slope.resize(this->slope.size()); + for (size_t i = 0; i < this->slope.size(); i++) { + selectivity->slope[i] = this->slope[i].initial_value_m; + if (this->slope[i].estimated_m) { + ss.str(""); + ss << "selectivity.slope." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->slope[i].is_random_effect_m) { + info->RegisterRandomEffect(selectivity->slope[i]); + } else { + info->RegisterParameter(selectivity->slope[i]); + } + } } - } + info->variable_map[this->slope.id_m] = &(selectivity)->slope; // add to Information info->selectivity_models[selectivity->id] = selectivity; @@ -117,9 +240,12 @@ class LogisticSelectivityInterface : public SelectivityInterfaceBase { return true; } - /** @brief this adds the parameter values and derivatives to the TMB model - * object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { + FIMS_INFO_LOG("adding Selectivity object to TMB"); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); @@ -133,16 +259,17 @@ class LogisticSelectivityInterface : public SelectivityInterfaceBase { /** * @brief Rcpp interface for logistic selectivity as an S4 object. To - * instantiate from R: logistic_selectivity <- new(logistic_selectivity) + * instantiate from R: logistic_selectivity <- methods::new(logistic_selectivity) */ class DoubleLogisticSelectivityInterface : public SelectivityInterfaceBase { public: - Parameter inflection_point_asc; /**< the index value at which the response + ParameterVector inflection_point_asc; /**< the index value at which the response reaches .5 */ - Parameter slope_asc; /**< the width of the curve at the inflection_point */ - Parameter inflection_point_desc; /**< the index value at which the response + ParameterVector slope_asc; /**< the width of the curve at the inflection_point */ + ParameterVector inflection_point_desc; /**< the index value at which the response reaches .5 */ - Parameter slope_desc; /**< the width of the curve at the inflection_point */ + ParameterVector slope_desc; /**< the width of the curve at the inflection_point */ + DoubleLogisticSelectivityInterface() : SelectivityInterfaceBase() {} @@ -157,13 +284,130 @@ class DoubleLogisticSelectivityInterface : public SelectivityInterfaceBase { */ virtual double evaluate(double x) { fims_popdy::DoubleLogisticSelectivity DoubleLogisticSel; - DoubleLogisticSel.inflection_point_asc = this->inflection_point_asc.value_m; - DoubleLogisticSel.slope_asc = this->slope_asc.value_m; - DoubleLogisticSel.inflection_point_desc = - this->inflection_point_desc.value_m; - DoubleLogisticSel.slope_desc = this->slope_desc.value_m; + DoubleLogisticSel.inflection_point_asc.resize(1); + DoubleLogisticSel.inflection_point_asc[0] = this->inflection_point_asc[0].initial_value_m; + DoubleLogisticSel.slope_asc.resize(1); + DoubleLogisticSel.slope_asc[0] = this->slope_asc[0].initial_value_m; + DoubleLogisticSel.inflection_point_desc.resize(1); + DoubleLogisticSel.inflection_point_desc[0] = + this->inflection_point_desc[0].initial_value_m; + DoubleLogisticSel.slope_desc.resize(1); + DoubleLogisticSel.slope_desc[0] = this->slope_desc[0].initial_value_m; return DoubleLogisticSel.evaluate(x); } + /** + * @brief finalize function. Extracts derived quantities back to + * the Rcpp interface object from the Information object. + */ + virtual void finalize() { + + if (this->finalized) { + //log warning that finalize has been called more than once. + FIMS_WARNING_LOG("Double Logistic Selectivity " + fims::to_string(this->id) + " has been finalized already."); + } + + this->finalized = true; //indicate this has been called already + + std::shared_ptr > info = + fims_info::Information::GetInstance(); + + + + fims_info::Information::selectivity_models_iterator it; + + //search for maturity in Information + it = info->selectivity_models.find(this->id); + //if not found, just return + if (it == info->selectivity_models.end()) { + FIMS_WARNING_LOG("Double Logistic Selectivity " + fims::to_string(this->id) + " not found in Information."); + return; + } else { + std::shared_ptr > sel = + std::dynamic_pointer_cast >(it->second); + + + for (size_t i = 0; i < inflection_point_asc.size(); i++) { + if (this->inflection_point_asc[i].estimated_m) { + this->inflection_point_asc[i].final_value_m = sel->inflection_point_asc[i]; + } else { + this->inflection_point_asc[i].final_value_m = this->inflection_point_asc[i].initial_value_m; + } + + } + + for (size_t i = 0; i < slope_asc.size(); i++) { + if (this->slope_asc[i].estimated_m) { + this->slope_asc[i].final_value_m = sel->slope_asc[i]; + } else { + this->slope_asc[i].final_value_m = this->slope_asc[i].initial_value_m; + } + + } + + for (size_t i = 0; i < inflection_point_desc.size(); i++) { + if (this->inflection_point_desc[i].estimated_m) { + this->inflection_point_desc[i].final_value_m = sel->inflection_point_desc[i]; + } else { + this->inflection_point_desc[i].final_value_m = this->inflection_point_desc[i].initial_value_m; + } + + } + + for (size_t i = 0; i < slope_desc.size(); i++) { + if (this->slope_desc[i].estimated_m) { + this->slope_desc[i].final_value_m = sel->slope_desc[i]; + } else { + this->slope_desc[i].final_value_m = this->slope_desc[i].initial_value_m; + } + + } + + + + } + } + + /** + * @brief Convert the data to json representation for the output. + */ + virtual std::string to_json() { + std::stringstream ss; + + ss << "\"module\" : {\n"; + ss << " \"name\": \"selectivity\",\n"; + ss << " \"type\": \"DoubleLogistic\",\n"; + ss << " \"id\": " << this->id << ",\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"inflection_point_asc\",\n"; + ss << " \"id\":" << this->inflection_point_asc.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->inflection_point_asc << ",\n},\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"slope_asc\",\n"; + ss << " \"id\":" << this->slope_asc.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->slope_asc << ",\n},\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"inflection_point_desc\",\n"; + ss << " \"id\":" << this->inflection_point_desc.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->inflection_point_desc << ",\n},\n"; + + ss << " \"parameter\": {\n"; + ss << " \"name\": \"slope_desc\",\n"; + ss << " \"id\":" << this->slope_desc.id_m << ",\n"; + ss << " \"type\": \"vector\",\n"; + ss << " \"values\":" << this->slope_desc << ",\n}\n"; + + + ss << "}"; + + return ss.str(); + } + #ifdef TMB_MODEL @@ -175,40 +419,76 @@ class DoubleLogisticSelectivityInterface : public SelectivityInterfaceBase { std::shared_ptr > selectivity = std::make_shared >(); - // set relative info - selectivity->id = this->id; - selectivity->inflection_point_asc = this->inflection_point_asc.value_m; - if (this->inflection_point_asc.estimated_m) { - if (this->inflection_point_asc.is_random_effect_m) { - info->RegisterRandomEffect(selectivity->inflection_point_asc); - } else { - info->RegisterParameter(selectivity->inflection_point_asc); - } - } - selectivity->slope_asc = this->slope_asc.value_m; - if (this->slope_asc.estimated_m) { - if (this->slope_asc.is_random_effect_m) { - info->RegisterRandomEffect(selectivity->slope_asc); - } else { - info->RegisterParameter(selectivity->slope_asc); - } - } - selectivity->inflection_point_desc = this->inflection_point_desc.value_m; - if (this->inflection_point_desc.estimated_m) { - if (this->inflection_point_desc.is_random_effect_m) { - info->RegisterRandomEffect(selectivity->inflection_point_desc); - } else { - info->RegisterParameter(selectivity->inflection_point_desc); - } - } - selectivity->slope_desc = this->slope_desc.value_m; - if (this->slope_desc.estimated_m) { - if (this->slope_desc.is_random_effect_m) { - info->RegisterRandomEffect(selectivity->slope_desc); - } else { - info->RegisterParameter(selectivity->slope_desc); - } - } + std::stringstream ss; + // set relative info + selectivity->id = this->id; + selectivity->inflection_point_asc.resize(this->inflection_point_asc.size()); + for (size_t i = 0; i < this->inflection_point_asc.size(); i++) { + selectivity->inflection_point_asc[i] = this->inflection_point_asc[i].initial_value_m; + if (this->inflection_point_asc[i].estimated_m) { + ss.str(""); + ss << "selectivity.inflection_point_asc." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->inflection_point_asc[i].is_random_effect_m) { + info->RegisterRandomEffect(selectivity->inflection_point_asc[i]); + } else { + info->RegisterParameter(selectivity->inflection_point_asc[i]); + } + } + } + + info->variable_map[this->inflection_point_asc.id_m] = &(selectivity)->inflection_point_asc; + + + selectivity->slope_asc.resize(this->slope_asc.size()); + for (size_t i = 0; i < this->slope_asc.size(); i++) { + selectivity->slope_asc[i] = this->slope_asc[i].initial_value_m; + if (this->slope_asc[i].estimated_m) { + ss.str(""); + ss << "selectivity.slope_asc." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->slope_asc[i].is_random_effect_m) { + info->RegisterRandomEffect(selectivity->slope_asc[i]); + } else { + info->RegisterParameter(selectivity->slope_asc[i]); + } + } + } + info->variable_map[this->slope_asc.id_m] = &(selectivity)->slope_asc; + + selectivity->inflection_point_desc.resize(this->inflection_point_desc.size()); + for (size_t i = 0; i < this->inflection_point_desc.size(); i++) { + selectivity->inflection_point_desc[i] = this->inflection_point_desc[i].initial_value_m; + if (this->inflection_point_desc[i].estimated_m) { + ss.str(""); + ss << "selectivity.inflection_point_desc." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->inflection_point_desc[i].is_random_effect_m) { + info->RegisterRandomEffect(selectivity->inflection_point_desc[i]); + } else { + info->RegisterParameter(selectivity->inflection_point_desc[i]); + } + } + } + + info->variable_map[this->inflection_point_desc.id_m] = &(selectivity)->inflection_point_desc; + selectivity->slope_desc.resize(this->slope_desc.size()); + for (size_t i = 0; i < this->slope_desc.size(); i++) { + selectivity->slope_desc[i] = this->slope_desc[i].initial_value_m; + if (this->slope_desc[i].estimated_m) { + ss.str(""); + ss << "selectivity.slope_desc." << this->id << "." << i; + info->RegisterParameterName(ss.str()); + if (this->slope_desc[i].is_random_effect_m) { + info->RegisterRandomEffect(selectivity->slope_desc[i]); + } else { + info->RegisterParameter(selectivity->slope_desc[i]); + } + } + } + + + info->variable_map[this->slope_desc.id_m] = &(selectivity)->slope_desc; // add to Information info->selectivity_models[selectivity->id] = selectivity; @@ -216,8 +496,10 @@ class DoubleLogisticSelectivityInterface : public SelectivityInterfaceBase { return true; } - /** @brief this adds the parameter values and derivatives to the TMB model - * object */ + /** + * @brief Adds the parameters to the TMB model. + * @return A boolean of true. + */ virtual bool add_to_fims_tmb() { this->add_to_fims_tmb_internal(); this->add_to_fims_tmb_internal(); @@ -230,4 +512,4 @@ class DoubleLogisticSelectivityInterface : public SelectivityInterfaceBase { #endif }; -#endif \ No newline at end of file +#endif diff --git a/inst/include/interface/rcpp/rcpp_objects/rcpp_tmb_distribution.hpp b/inst/include/interface/rcpp/rcpp_objects/rcpp_tmb_distribution.hpp deleted file mode 100644 index 9c21eed00..000000000 --- a/inst/include/interface/rcpp/rcpp_objects/rcpp_tmb_distribution.hpp +++ /dev/null @@ -1,274 +0,0 @@ -/* - * File: rcpp_distributions.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - */ -#ifndef FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_TMB_DISTRIBUTION_HPP -#define FIMS_INTERFACE_RCPP_RCPP_OBJECTS_RCPP_TMB_DISTRIBUTION_HPP - -#include "../../../distributions/distributions.hpp" -#include "../../interface.hpp" -#include "rcpp_interface_base.hpp" - -/** - * @brief Distributions Rcpp Interface - * - */ -class DistributionsInterfaceBase : public FIMSRcppInterfaceBase { - public: - static uint32_t - id_g; /**< static id of the DistributionsInterfaceBase object */ - uint32_t id; /**< local id of the DistributionsInterfaceBase object */ - // live objects in C++ are objects that have been created and live in memory - static std::map live_objects; /**< -map relating the ID of the DistributionsInterfaceBase to the -DistributionsInterfaceBase objects */ - - DistributionsInterfaceBase() { - this->id = DistributionsInterfaceBase::id_g++; - /* Create instance of map: key is id and value is pointer to - DistributionsInterfaceBase */ - DistributionsInterfaceBase::live_objects[this->id] = this; - FIMSRcppInterfaceBase::fims_interface_objects.push_back(this); - } - - virtual ~DistributionsInterfaceBase() {} - - /** @brief get_id method for child distribution interface objects to inherit - */ - virtual uint32_t get_id() = 0; - - /** @brief evaluate method for child distribution interface objects to inherit - */ - virtual double evaluate(bool do_log) = 0; -}; - -uint32_t DistributionsInterfaceBase::id_g = - 1; /**< static id of the DistributionsInterfaceBase object */ -std::map /**< local id of the DistributionsInterfaceBase object */ - DistributionsInterfaceBase::live_objects; /**< - map relating the ID of the DistributionsInterfaceBase to the - DistributionsInterfaceBase objects */ - -/** - * @brief Rcpp interface for Dnorm as an S4 object. To instantiate - * from R: - * dnorm_ <- new(TMBDnormDistribution) - * - */ -class DnormDistributionsInterface : public DistributionsInterfaceBase { - public: - Parameter x; /**< observed data */ - Parameter mean; /**< mean of x for the normal distribution */ - Parameter sd; /**< sd of x for the normal distribution */ - - DnormDistributionsInterface() : DistributionsInterfaceBase() {} - - virtual uint32_t get_id() { return this->id; } - - virtual ~DnormDistributionsInterface() {} - - /** - * @brief Evaluate normal probability density function, default returns the - * log of the pdf - * - * @tparam T - * @return log pdf - */ - virtual double evaluate(bool do_log) { - fims_distributions::Dnorm dnorm; - dnorm.x = this->x.value_m; - dnorm.mean = this->mean.value_m; - dnorm.sd = this->sd.value_m; - return dnorm.evaluate(do_log); - } - -#ifdef TMB_MODEL - - template - bool add_to_fims_tmb_internal() { - std::shared_ptr> info = - fims_info::Information::GetInstance(); - - std::shared_ptr> distribution = - std::make_shared>(); - - // interface to data/parameter value - distribution->id = this->id; - distribution->x = this->x.value_m; - // set relative info - distribution->mean = this->mean.value_m; - distribution->sd = this->sd.value_m; - - info->distribution_models[distribution->id] = distribution; - - return true; - } - - /** - * @brief adds the dnorm distribution and its parameters to the TMB model - */ - virtual bool add_to_fims_tmb() { - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - - return true; - } - -#endif -}; - -/** - * @brief Rcpp interface for Dlnorm as an S4 object. To instantiate - * from R: - * dlnorm_ <- new(TMBDlnormDistribution) - * - */ -class DlnormDistributionsInterface : public DistributionsInterfaceBase { - public: - Parameter x; /**< observation */ - Parameter meanlog; /**< mean of the distribution of log(x) */ - Parameter sdlog; /**< standard deviation of the distribution of log(x) */ - - DlnormDistributionsInterface() : DistributionsInterfaceBase() {} - - virtual ~DlnormDistributionsInterface() {} - - /** - * @brief get the id of the Dlnorm distributions interface class object - */ - virtual uint32_t get_id() { return this->id; } - - /** - * @brief Evaluate lognormal probability density function, default returns the - * log of the pdf - * - * @tparam T - * @return log pdf - */ - virtual double evaluate(bool do_log) { - fims_distributions::Dlnorm dlnorm; - dlnorm.x = this->x.value_m; - dlnorm.meanlog = this->meanlog.value_m; - dlnorm.sdlog = this->sdlog.value_m; - return dlnorm.evaluate(do_log); - } - -#ifdef TMB_MODEL - - template - bool add_to_fims_tmb_internal() { - std::shared_ptr> info = - fims_info::Information::GetInstance(); - - std::shared_ptr> distribution = - std::make_shared>(); - - // set relative info - distribution->id = this->id; - distribution->x = this->x.value_m; - distribution->meanlog = this->meanlog.value_m; - distribution->sdlog = this->sdlog.value_m; - - info->distribution_models[distribution->id] = distribution; - - return true; - } - - /** - * @brief adds the dlnorm distribution and its parameters to the TMB model - */ - virtual bool add_to_fims_tmb() { - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - - return true; - } - -#endif -}; - -/** - * @brief Rcpp interface for Dmultinom as an S4 object. To instantiate - * from R: - * dmultinom_ <- new(TMBDmultinomDistribution) - * - */ -// template - -class DmultinomDistributionsInterface : public DistributionsInterfaceBase { - public: - Rcpp::IntegerVector x; /**< Vector of length K of integers */ - Rcpp::NumericVector p; /**< Vector of length K, specifying the probability - for the K classes (note, unlike in R these must sum to 1). */ - - DmultinomDistributionsInterface() : DistributionsInterfaceBase() {} - - virtual ~DmultinomDistributionsInterface() {} - - virtual uint32_t get_id() { return this->id; } - - /** - * @brief Evaluate multinom probability density function, default returns the - * log of the pdf - * - * @tparam T - * @return log pdf - */ - virtual double evaluate(bool do_log) { - fims_distributions::Dmultinom dmultinom; - // Declare TMBVector in this scope - dmultinom.x.resize(x.size()); // Vector from TMB - dmultinom.p.resize(p.size()); // Vector from TMB - for (int i = 0; i < x.size(); i++) { - dmultinom.x[i] = x[i]; - dmultinom.p[i] = p[i]; - } - return dmultinom.evaluate(do_log); - } - -#ifdef TMB_MODEL - - template - bool add_to_fims_tmb_internal() { - std::shared_ptr> info = - fims_info::Information::GetInstance(); - - std::shared_ptr> distribution = - std::make_shared>(); - - distribution->id = this->id; - distribution->x.resize(x.size()); - distribution->p.resize(p.size()); - - for (int i = 0; i < x.size(); i++) { - distribution->x[i] = x[i]; - distribution->p[i] = p[i]; - } - - info->distribution_models[distribution->id] = distribution; - - return true; - } - - virtual bool add_to_fims_tmb() { - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - this->add_to_fims_tmb_internal(); - - return true; - } - -#endif -}; -#endif diff --git a/inst/include/population_dynamics/fleet/fleet.hpp b/inst/include/population_dynamics/fleet/fleet.hpp index 42698de86..d9de028ad 100644 --- a/inst/include/population_dynamics/fleet/fleet.hpp +++ b/inst/include/population_dynamics/fleet/fleet.hpp @@ -1,11 +1,10 @@ -/** \file fleet.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. - * - * The purpose of this file is to declare the fleet functor class - * which is the base class for all fleet functors. +/** + * @file fleet.hpp + * @brief Declare the fleet functor class which is the base class for all fleet + * functors. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_FLEET_HPP #define FIMS_POPULATION_DYNAMICS_FLEET_HPP @@ -18,223 +17,225 @@ namespace fims_popdy { -/** @brief Base class for all fleets. - * - * @tparam Type The type of the fleet object. - */ -template -struct Fleet : public fims_model_object::FIMSObject { - static uint32_t id_g; /*!< reference id for fleet object*/ - size_t nyears; /*!< the number of years in the model*/ - size_t nages; /*!< the number of ages in the model*/ - - // This likelihood index is not currently being used as only one likelihood - // distribution is available. These are for a future update M2+. - int fleet_index_likelihood_id_m = - -999; /*!> - index_likelihood; /*!< index likelihood component*/ - - // This likelihood index is not currently being used as only one likelihood - // distribution is available. These are for a future update M2+. - int fleet_agecomp_likelihood_id_m = - -999; /*!< id of agecomp likelihood component*/ - std::shared_ptr> - agecomp_likelihood; /*!< agecomp likelihood component*/ - - // selectivity - int fleet_selectivity_id_m = -999; /*!< id of selectivity component*/ - std::shared_ptr> - selectivity; /*!< selectivity component*/ - + /** @brief Base class for all fleets. + * + * @tparam Type The type of the fleet object. + */ + template + struct Fleet : public fims_model_object::FIMSObject { + static uint32_t id_g; /*!< reference id for fleet object*/ + size_t nyears; /*!< the number of years in the model*/ + size_t nages; /*!< the number of ages in the model*/ + size_t nlengths; /*!< the number of lengths in the model*/ + + // selectivity + int fleet_selectivity_id_m = -999; /*!< id of selectivity component*/ + std::shared_ptr> + selectivity; /*!< selectivity component*/ + + // index data int fleet_observed_index_data_id_m = -999; /*!< id of index data */ std::shared_ptr> - observed_index_data; /*!< observed index data*/ + observed_index_data; /*!< observed index data*/ + // age comp data int fleet_observed_agecomp_data_id_m = -999; /*!< id of age comp data */ std::shared_ptr> - observed_agecomp_data; /*!< observed agecomp data*/ + observed_agecomp_data; /*!< observed agecomp data*/ + + // length comp data + int fleet_observed_lengthcomp_data_id_m = -999; /*!< id of length comp data */ + std::shared_ptr> + observed_lengthcomp_data; /*!< observed lengthcomp data*/ // Mortality and catchability fims::Vector log_Fmort; /*!< estimated parameter: log Fishing mortality*/ - Type log_q; /*!< estimated parameter: catchability of the fleet */ - - fims::Vector log_obs_error; /*!< estimated parameters: observation error - associated with index */ - fims::Vector Fmort; /*!< transformed parameter: Fishing mortality*/ - Type q; /*!< transofrmed parameter: the catchability of the fleet */ - - // derived quantities - fims::Vector catch_at_age; /*! catch_index; /*! age_composition; /*! expected_catch; /*! expected_index; /*! catch_numbers_at_age; /*! catch_weight_at_age; /*! log_q; /*!< estimated parameter: catchability of the fleet */ + + fims::Vector Fmort; /*!< transformed parameter: Fishing mortality*/ + fims::Vector q; /*!< transformed parameter: the catchability of the fleet */ + + // derived quantities + fims::Vector catch_at_age; /*! catch_index; /*! age_composition; /*! length_composition; /*! age_length_conversion_matrix; /*! observed_catch_lpdf; /*! observed_index_lpdf; /*! expected_catch; /*! expected_index; /*! log_expected_index; /*! expected_catch_lpdf; /*! expected_index_lpdf; /*! catch_numbers_at_age; /*! catch_numbers_at_length; /*! proportion_catch_numbers_at_age; /*! proportion_catch_numbers_at_length; /*! catch_weight_at_age; /*! *of; + ::objective_function *of; #endif - /** - * @brief Constructor. - */ - Fleet() { this->id = Fleet::id_g++; } - - /** - * @brief Destructor. - */ - virtual ~Fleet() {} - - /** - * @brief Intialize Fleet Class - * @param nyears The number of years in the model. - * @param nages The number of ages in the model. - */ - void Initialize(int nyears, int nages) { - this->nyears = nyears; - this->nages = nages; - - catch_at_age.resize(nyears * nages); - catch_weight_at_age.resize(nyears * nages); - catch_index.resize(nyears); // assume index is for all ages. - age_composition.resize(nyears * nages); - expected_catch.resize(nyears); - expected_index.resize(nyears); // assume index is for all ages. - catch_numbers_at_age.resize(nyears * nages); - - log_obs_error.resize(nyears); - log_Fmort.resize(nyears); - Fmort.resize(nyears); - } - - /** - * @brief Prepare to run the fleet module. Called at each model itartion, and - * used to exponentiate the log q and Fmort parameters prior to evaluation. - * - */ - void Prepare() { - // for(size_t fleet_ = 0; fleet_ <= this->nfleets; fleet_++) { - // this -> Fmort[fleet_] = fims_math::exp(this -> log_Fmort[fleet_]); - - // derived quantities - std::fill(catch_at_age.begin(), catch_at_age.end(), - 0); /**q = fims_math::exp(this->log_q); - for (size_t year = 0; year < this->nyears; year++) { - FLEET_LOG << "input F mort " << this->log_Fmort[year] << std::endl; - FLEET_LOG << "input q " << this->log_q << std::endl; - FLEET_LOG << "input log_obs_error " << this->log_obs_error[year] - << std::endl; - this->Fmort[year] = fims_math::exp(this->log_Fmort[year]); - } - } - - virtual const Type evaluate_age_comp_nll() { - Type nll = 0.0; /**< The negative log likelihood value */ -#ifdef TMB_MODEL - fims_distributions::Dmultinom dmultinom; - size_t dims = this->observed_agecomp_data->get_imax() * - this->observed_agecomp_data->get_jmax(); - if (dims != this->catch_numbers_at_age.size()) { - ERROR_LOG << "Error: observed age comp is of size " << dims - << " and expected is of size " << this->age_composition.size() - << std::endl; - exit(1); - - } else { - for (size_t y = 0; y < this->nyears; y++) { - fims::Vector observed_acomp; - fims::Vector expected_acomp; - - observed_acomp.resize(this->nages); - expected_acomp.resize(this->nages); - Type sum = 0.0; - bool containsNA = - false; /**< skips the entire year if any values are NA */ - for (size_t a = 0; a < this->nages; a++) { - if (this->observed_agecomp_data->at(y, a) != - this->observed_agecomp_data->na_value) { - size_t i_age_year = y * this->nages + a; - sum += this->catch_numbers_at_age[i_age_year]; - } else { - containsNA = true; /**< sets to true if any values are NA >*/ - break; - } + /** + * @brief Constructor. + */ + Fleet() { + this->id = Fleet::id_g++; } - if (!containsNA) { - for (size_t a = 0; a < this->nages; a++) { - size_t i_age_year = y * this->nages + a; - expected_acomp[a] = this->catch_numbers_at_age[i_age_year] / - sum; // probabilities for ages - observed_acomp[a] = this->observed_agecomp_data->at(y, a); + /** + * @brief Destructor. + */ + virtual ~Fleet() { + } - FLEET_LOG << " age " << a << " in year " << y - << "has expected: " << expected_acomp[a] - << " and observed: " << observed_acomp[a] << std::endl; - } - dmultinom.x = observed_acomp; - dmultinom.p = expected_acomp; - nll -= dmultinom.evaluate(true); + /** + * @brief Intialize Fleet Class + * @param nyears The number of years in the model. + * @param nages The number of ages in the model. + * @param nlengths The number of lengths in the model. + */ + void Initialize(int nyears, int nages, int nlengths = 0) { + if (this->log_q.size() == 0) { + this->log_q.resize(1); + this->log_q[0] = 0.0; + } + this->nyears = nyears; + this->nages = nages; + this->nlengths = nlengths; + + catch_at_age.resize(nyears * nages); + catch_numbers_at_age.resize(nyears * nages); + catch_numbers_at_length.resize(nyears * nlengths); + proportion_catch_numbers_at_age.resize(nyears * nages); + proportion_catch_numbers_at_length.resize(nyears * nlengths); + age_length_conversion_matrix.resize(nages * nlengths); + catch_weight_at_age.resize(nyears * nages); + catch_index.resize(nyears); // assume index is for all ages. + expected_catch.resize(nyears); + expected_index.resize(nyears); + log_expected_index.resize(nyears); + age_composition.resize(nyears * nages); + length_composition.resize(nyears * nlengths); + q.resize(this->log_q.size()); + log_Fmort.resize(nyears); + Fmort.resize(nyears); } - } - } - FLEET_LOG << "Age comp negative log-likelihood for fleet," << this->id - << nll << std::endl; -#endif - return nll; - } - virtual const Type evaluate_index_nll() { - Type nll = 0.0; /*!< The negative log likelihood value */ + /** + * @brief Prepare to run the fleet module. Called at each model + * iteration, and used to exponentiate the natural log of q and Fmort + * parameters prior to evaluation. + * + */ + void Prepare() { + // for(size_t fleet_ = 0; fleet_ <= this->nfleets; fleet_++) { + // this -> Fmort[fleet_] = fims_math::exp(this -> log_Fmort[fleet_]); + + // derived quantities + std::fill(catch_at_age.begin(), catch_at_age.end(), + 0); /**log_q.size(); i++) { + this->q[i] = fims_math::exp(this->log_q[i]); + } + + for (size_t year = 0; year < this->nyears; year++) { + this->Fmort[year] = fims_math::exp(this->log_Fmort[year]); + } + } -#ifdef TMB_MODEL - fims_distributions::Dnorm dnorm; - for (size_t i = 0; i < this->expected_index.size(); i++) { - if (this->observed_index_data->at(i) != - this->observed_index_data->na_value) { - dnorm.x = fims_math::log(this->observed_index_data->at(i)); - dnorm.mean = fims_math::log(this->expected_index[i]); - dnorm.sd = fims_math::exp(this->log_obs_error[i]); - nll -= dnorm.evaluate(true); - } - - FLEET_LOG << "observed index data: " << i << " is " - << this->observed_index_data->at(i) - << " and expected is: " << this->expected_index[i] << std::endl; - FLEET_LOG << " log obs error is: " << this->log_obs_error[i] << std::endl; - } - FLEET_LOG << " sd is: " << dnorm.sd << std::endl; - FLEET_LOG << " index nll: " << nll << std::endl; + /** + * Evaluate the proportion of catch numbers at age. + */ + void evaluate_age_comp() { + for (size_t y = 0; y < this->nyears; y++) { + Type sum = 0.0; + for (size_t a = 0; a < this->nages; a++) { + size_t i_age_year = y * this->nages + a; + sum += this->catch_numbers_at_age[i_age_year]; + } + for (size_t a = 0; a < this->nages; a++) { + size_t i_age_year = y * this->nages + a; + this->proportion_catch_numbers_at_age[i_age_year] = this->catch_numbers_at_age[i_age_year] / sum; + + } + } + } -#endif - return nll; - } -}; + /** + * Evaluate the proportion of catch numbers at length. + */ + void evaluate_length_comp() { + if (this->nlengths > 0) { + for (size_t y = 0; y < this->nyears; y++) { + Type sum = 0.0; + for (size_t l = 0; l < this->nlengths; l++) { + size_t i_length_year = y * this->nlengths + l; + for(size_t a = 0; a < this->nages; a++) { + size_t i_age_year = y * this->nages + a; + size_t i_length_age = a * this->nlengths + l; + this->catch_numbers_at_length[i_length_year] += + this->catch_numbers_at_age[i_age_year] * + this->age_length_conversion_matrix[i_length_age]; + } + sum += this->catch_numbers_at_length[i_length_year]; + } + for (size_t l = 0; l < this->nlengths; l++) { + size_t i_length_year = y * this->nlengths + l; + this->proportion_catch_numbers_at_length[i_length_year] = + this->catch_numbers_at_length[i_length_year] / sum; + } + } + } + } + + /** + * Evaluate the natural log of the expected index. + */ + void evaluate_index() { + for (size_t i = 0; iexpected_index.size(); i++) { + log_expected_index[i] = log(this->expected_index[i]); + } + } + }; -// default id of the singleton fleet class -template -uint32_t Fleet::id_g = 0; + // default id of the singleton fleet class + template + uint32_t Fleet::id_g = 0; -} // end namespace fims_popdy +} // end namespace fims_popdy #endif /* FIMS_POPULATION_DYNAMICS_FLEET_HPP */ diff --git a/inst/include/population_dynamics/growth/functors/ewaa.hpp b/inst/include/population_dynamics/growth/functors/ewaa.hpp index 62ff5c5d8..b32d853ed 100644 --- a/inst/include/population_dynamics/growth/functors/ewaa.hpp +++ b/inst/include/population_dynamics/growth/functors/ewaa.hpp @@ -1,10 +1,10 @@ -/* - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. - * - * The purpose of this file is to declare the growth functor class - * which is the base class for all growth functors. +/** + * @file ewaa.hpp + * @brief Declares the growth functor class which is the base class for all + * growth functors. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef POPULATION_DYNAMICS_GROWTH_EWAA_HPP #define POPULATION_DYNAMICS_GROWTH_EWAA_HPP @@ -28,6 +28,7 @@ struct EWAAgrowth : public GrowthBase { // the value is the weight at that age (second double) std::map ewaa; /** */ + typedef typename std::map::iterator weight_iterator; /**< Iterator for ewaa map object > */ EWAAgrowth() : GrowthBase() {} @@ -39,7 +40,11 @@ struct EWAAgrowth : public GrowthBase { * @param a age of the fish, the age vector must start at zero */ virtual const Type evaluate(const double& a) { - Type ret = ewaa[a]; + weight_iterator it = this->ewaa.find(a); + if(it == this->ewaa.end() ){ + return 0.0; + } + Type ret = (*it).second;//itewaa[a]; return ret; } }; diff --git a/inst/include/population_dynamics/growth/functors/growth_base.hpp b/inst/include/population_dynamics/growth/functors/growth_base.hpp index 0b2aaabc8..45a58d6fa 100644 --- a/inst/include/population_dynamics/growth/functors/growth_base.hpp +++ b/inst/include/population_dynamics/growth/functors/growth_base.hpp @@ -1,15 +1,12 @@ -/* - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * - * growth module_base file - * The purpose of this file is to include any .hpp files within the - * subfolders so that only this file needs to included in the model.hpp file. - * - * DEFINE guards for growth module outline to define the +/** + * @file growth_base.hpp + * @brief Includes any .hpp files within the subfolders so that only this file + * needs to included in the model.hpp file. + * @details Defines guards for growth module outline to define the * module_name_base hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef POPULATION_DYNAMICS_GROWTH_BASE_HPP #define POPULATION_DYNAMICS_GROWTH_BASE_HPP diff --git a/inst/include/population_dynamics/growth/growth.hpp b/inst/include/population_dynamics/growth/growth.hpp index ae63f0c17..7dbc8ef5f 100644 --- a/inst/include/population_dynamics/growth/growth.hpp +++ b/inst/include/population_dynamics/growth/growth.hpp @@ -1,15 +1,12 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Growth module file - * The purpose of this file is to include any .hpp files within the - * subfolders so that only this file needs to included in the model.hpp file. - * - * DEFINE guards for growth module outline to define the - * growth hpp file if not already defined. +/** + * @file growth.hpp + * @brief Includes any .hpp files within the subfolders so that only this file + * needs to included in the model.hpp file. + * @details Defines guards for growth module outline to define the growth hpp + * file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_GROWTH_HPP #define FIMS_POPULATION_DYNAMICS_GROWTH_HPP diff --git a/inst/include/population_dynamics/maturity/functors/logistic.hpp b/inst/include/population_dynamics/maturity/functors/logistic.hpp index 619a9ee6f..fd353aa9e 100644 --- a/inst/include/population_dynamics/maturity/functors/logistic.hpp +++ b/inst/include/population_dynamics/maturity/functors/logistic.hpp @@ -1,16 +1,17 @@ -/* - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. +/** + * @file logistic.hpp + * @brief Defines the LogisticMaturity class, which inherits from the + * MaturityBase class. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. * - * The purpose of this file is to define the LogisticMaturity class, which - * inherits from the MaturityBase class */ #ifndef POPULATION_DYNAMICS_MATURITY_LOGISTIC_HPP #define POPULATION_DYNAMICS_MATURITY_LOGISTIC_HPP -//#include "../../../interface/interface.hpp" #include "../../../common/fims_math.hpp" +#include "../../../common/fims_vector.hpp" #include "maturity_base.hpp" namespace fims_popdy { @@ -21,28 +22,46 @@ namespace fims_popdy { */ template struct LogisticMaturity : public MaturityBase { - Type inflection_point; /**< 50% quantile of the value of the quantity of - interest (x); e.g. age at which 50% of the fish are mature */ - Type slope; /** inflection_point; /**< 50 percent quantile of the value of the quantity of + interest (x); e.g. age at which 50 percent of the fish are mature */ + fims::Vector slope; /**() {} - - /** - * @brief Method of the logistic maturity class that implements the - * logistic function from FIMS math. - * - * \f[ \frac{1.0}{ 1.0 + exp(-1.0 * slope (x - inflection_point))} \f] - * - * @param x The independent variable in the logistic function (e.g., age or - * size at maturity). - */ - - virtual const Type evaluate(const Type& x) { - return fims_math::logistic(inflection_point, slope, x); - } + LogisticMaturity() : MaturityBase() + { + } + + /** + * @brief Method of the logistic maturity class that implements the + * logistic function from FIMS math. + * + * \f[ \frac{1.0}{ 1.0 + exp(-1.0 * slope (x - inflection_point))} \f] + * + * @param x The independent variable in the logistic function (e.g., age or + * size at maturity). + */ + + virtual const Type evaluate(const Type& x) + { + return fims_math::logistic(inflection_point[0], slope[0], x); + } + + /** + * @brief Method of the logistic maturity class that implements the + * logistic function from FIMS math. + * + * \f[ \frac{1.0}{ 1.0 + exp(-1.0 * slope_t (x - {inflection\_point}_t))} \f] + * + * @param x The independent variable in the logistic function (e.g., age or + * size in selectivity). + * @param pos Position index, e.g., which year. + */ + virtual const Type evaluate(const Type& x, size_t pos) + { + return fims_math::logistic(inflection_point.get_force_scalar(pos), slope.get_force_scalar(pos), x); + } }; -} // namespace fims_popdy +} // namespace fims_popdy #endif /* POPULATION_DYNAMICS_MATURITY_LOGISTIC_HPP */ diff --git a/inst/include/population_dynamics/maturity/functors/maturity_base.hpp b/inst/include/population_dynamics/maturity/functors/maturity_base.hpp index f3f6aadba..1ee6d3083 100644 --- a/inst/include/population_dynamics/maturity/functors/maturity_base.hpp +++ b/inst/include/population_dynamics/maturity/functors/maturity_base.hpp @@ -1,15 +1,12 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * maturity_base.hpp - * The purpose of this file is to declare the MaturityBase class - * which is the base class for all maturity functors. - * - * DEFINE guards for maturity module outline to define the - * maturity hpp file if not already defined. +/** + * @file maturity_base.hpp + * @brief Declares the MaturityBase class which is the base class for all + * maturity functors. + * @details Defines guards for maturity module outline to define the maturity + * hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef POPULATION_DYNAMICS_MATURITY_BASE_HPP #define POPULATION_DYNAMICS_MATURITY_BASE_HPP @@ -25,31 +22,39 @@ namespace fims_popdy { template struct MaturityBase : public fims_model_object::FIMSObject { - // id_g is the ID of the instance of the MaturityBase class. - // this is like a memory tracker. - // Assigning each one its own ID is a way to keep track of - // all the instances of the MaturityBase class. - static uint32_t id_g; /**< The ID of the instance of the MaturityBase class */ - - /** @brief Constructor. - */ - MaturityBase() { - // increment id of the singleton maturity class - this->id = MaturityBase::id_g++; - } - - /** - * @brief Calculates the maturity. - * @param x The independent variable in the maturity function (e.g., logistic - * maturity at age or size). - */ - virtual const Type evaluate(const Type& x) = 0; + // id_g is the ID of the instance of the MaturityBase class. + // this is like a memory tracker. + // Assigning each one its own ID is a way to keep track of + // all the instances of the MaturityBase class. + static uint32_t id_g; /**< The ID of the instance of the MaturityBase class */ + + /** @brief Constructor. + */ + MaturityBase() + { + // increment id of the singleton maturity class + this->id = MaturityBase::id_g++; + } + + /** + * @brief Calculates the maturity. + * @param x The independent variable in the maturity function (e.g., logistic + * maturity at age or size). + */ + virtual const Type evaluate(const Type& x) = 0; + /** + * @brief Calculates the selectivity. + * @param x The independent variable in the logistic function (e.g., age or + * size in selectivity). + * @param pos Position index, e.g., which year. + */ + virtual const Type evaluate(const Type& x, size_t pos) = 0; }; // default id of the singleton maturity class template uint32_t MaturityBase::id_g = 0; -} // namespace fims_popdy +} // namespace fims_popdy #endif /* POPULATION_DYNAMICS_MATURITY_BASE_HPP */ diff --git a/inst/include/population_dynamics/maturity/maturity.hpp b/inst/include/population_dynamics/maturity/maturity.hpp index 9ec2f87f5..158c8fdd4 100644 --- a/inst/include/population_dynamics/maturity/maturity.hpp +++ b/inst/include/population_dynamics/maturity/maturity.hpp @@ -1,15 +1,13 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Maturity module file - * The purpose of this file is to include any .hpp files within the - * subfolders so that only this file needs to included in the model.hpp file. - * - * DEFINE guards for module_type module outline to define the +/** + * @file maturity.hpp + * @brief Includes any .hpp files within the subfolders so that only this file + * needs to included in the model.hpp file. + * @details Defines guards for module_type module outline to define the * module_type hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. + * */ #ifndef FIMS_POPULATION_DYNAMICS_MATURITY_HPP #define FIMS_POPULATION_DYNAMICS_MATURITY_HPP diff --git a/inst/include/population_dynamics/population/population.hpp b/inst/include/population_dynamics/population/population.hpp index 61b2543b2..d7c7690bc 100644 --- a/inst/include/population_dynamics/population/population.hpp +++ b/inst/include/population_dynamics/population/population.hpp @@ -1,15 +1,9 @@ -/* - * File: population.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Population module file - * The purpose of this file is to define the Population class and its fields - * and methods. - * - * +/** + * @file population.hpp + * @brief Defines the Population class and its fields and methods. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_POPULATION_HPP #define FIMS_POPULATION_DYNAMICS_POPULATION_HPP @@ -18,704 +12,612 @@ #include "../fleet/fleet.hpp" #include "../growth/growth.hpp" #include "../recruitment/recruitment.hpp" -//#include "subpopulation.hpp" #include "../../interface/interface.hpp" #include "../maturity/maturity.hpp" namespace fims_popdy { -/*TODO: - Review, add functions to evaluate, push vectors back to fleet (or point to - fleet directly?) - */ + /*TODO: + Review, add functions to evaluate, push vectors back to fleet (or point to + fleet directly?) + */ -/** - * @brief Population class. Contains subpopulations - * that are divided into generic partitions (eg. sex, area). - */ -template -struct Population : public fims_model_object::FIMSObject { - static uint32_t id_g; /*!< reference id for population object*/ - size_t nyears; /*!< total number of years in the fishery*/ - size_t nseasons; /*!< total number of seasons in the fishery*/ - size_t nages; /*!< total number of ages in the population*/ - size_t nfleets; /*!< total number of fleets in the fishery*/ - - // parameters are estimated; after initialize in create_model, push_back to - // parameter list - in information.hpp (same for initial F in fleet) - fims::Vector - log_init_naa; /*!< estimated parameter: log numbers at age*/ - fims::Vector log_M; /*!< estimated parameter: log Natural Mortality*/ - fims::Vector - proportion_female; /*!< estimated parameter: proportion female by age */ - - // Transformed values - fims::Vector M; /*!< transformed parameter: Natural Mortality*/ - - fims::Vector ages; /*!< vector of the ages for referencing*/ - fims::Vector years; /*!< vector of years for referencing*/ - fims::Vector mortality_F; /*!< vector of fishing mortality summed across + /** + * @brief Population class. Contains subpopulations + * that are divided into generic partitions (eg. sex, area). + */ + template + struct Population : public fims_model_object::FIMSObject { + static uint32_t id_g; /*!< reference id for population object*/ + size_t nyears; /*!< total number of years in the fishery*/ + size_t nseasons; /*!< total number of seasons in the fishery*/ + size_t nages; /*!< total number of ages in the population*/ + size_t nfleets; /*!< total number of fleets in the fishery*/ + + // parameters are estimated; after initialize in create_model, push_back to + // parameter list - in information.hpp (same for initial F in fleet) + fims::Vector + log_init_naa; /*!< estimated parameter: natural log of numbers at age*/ + fims::Vector log_M; /*!< estimated parameter: natural log of Natural Mortality*/ + fims::Vectorproportion_female = 0.5; /*!< proportion female by age */ + + // Transformed values + fims::Vector M; /*!< transformed parameter: natural mortality*/ + + fims::Vector ages; /*!< vector of the ages for referencing*/ + fims::Vector years; /*!< vector of years for referencing*/ + fims::Vector mortality_F; /*!< vector of fishing mortality summed across fleet by year and age*/ - fims::Vector - mortality_Z; /*!< vector of total mortality by year and age*/ - - // derived quantities - fims::Vector - weight_at_age; /*!< Derived quantity: expected weight at age */ - // fecundity removed because we don't need it yet - fims::Vector numbers_at_age; /*!< Derived quantity: population expected + fims::Vector + mortality_Z; /*!< vector of total mortality by year and age*/ + + // derived quantities + fims::Vector + weight_at_age; /*!< Derived quantity: expected weight at age */ + // fecundity removed because we don't need it yet + fims::Vector numbers_at_age; /*!< Derived quantity: population expected numbers at age in each year*/ - fims::Vector - unfished_numbers_at_age; /*!< Derived quantity: population expected + fims::Vector + unfished_numbers_at_age; /*!< Derived quantity: population expected unfished numbers at age in each year*/ - fims::Vector - biomass; /*!< Derived quantity: total population biomass in each year*/ - fims::Vector spawning_biomass; /*!< Derived quantity: Spawning_biomass*/ - fims::Vector unfished_biomass; /*!< Derived quanity + fims::Vector + biomass; /*!< Derived quantity: total population biomass in each year*/ + fims::Vector spawning_biomass; /*!< Derived quantity: Spawning_biomass*/ + fims::Vector unfished_biomass; /*!< Derived quanity biomass assuming unfished*/ - fims::Vector unfished_spawning_biomass; /*!< Derived quanity Spawning + fims::Vector unfished_spawning_biomass; /*!< Derived quanity Spawning biomass assuming unfished*/ - fims::Vector proportion_mature_at_age; /*!< Derived quantity: Proportion + fims::Vector proportion_mature_at_age; /*!< Derived quantity: Proportion mature at age */ - fims::Vector expected_numbers_at_age; /*!< Expected values: Numbers at + fims::Vector expected_numbers_at_age; /*!< Expected values: Numbers at age (thousands?? millions??) */ - fims::Vector expected_catch; /*!< Expected values: Catch*/ - fims::Vector expected_recruitment; /*!< Expected recruitment */ - /// recruitment - int recruitment_id = -999; /*!< id of recruitment model object*/ - std::shared_ptr> - recruitment; /*!< shared pointer to recruitment module */ - - // growth - int growth_id = -999; /*!< id of growth model object*/ - std::shared_ptr> - growth; /*!< shared pointer to growth module */ - - // maturity - int maturity_id = -999; /*!< id of maturity model object*/ - std::shared_ptr> - maturity; /*!< shared pointer to maturity module */ - - // fleet - int fleet_id = -999; /*!< id of fleet model object*/ - std::vector>> - fleets; /*!< shared pointer to fleet module */ - - // Define objective function object to be able to REPORT and ADREPORT + fims::Vector expected_catch; /*!< Expected values: Catch*/ + fims::Vector expected_recruitment; /*!< Expected recruitment */ + /// recruitment + int recruitment_id = -999; /*!< id of recruitment model object*/ + std::shared_ptr> + recruitment; /*!< shared pointer to recruitment module */ + + // growth + int growth_id = -999; /*!< id of growth model object*/ + std::shared_ptr> + growth; /*!< shared pointer to growth module */ + + // maturity + int maturity_id = -999; /*!< id of maturity model object*/ + std::shared_ptr> + maturity; /*!< shared pointer to maturity module */ + + // fleet + int fleet_id = -999; /*!< id of fleet model object*/ + std::vector>> + fleets; /*!< shared pointer to fleet module */ + + // Define objective function object to be able to REPORT and ADREPORT #ifdef TMB_MODEL - ::objective_function - *of; // :: references global namespace, defined in src/FIMS.cpp, - // available anywhere in the R package + ::objective_function + *of; // :: references global namespace, defined in src/FIMS.cpp, + // available anywhere in the R package #endif - // this -> means you're referring to a class member (member of self) - - Population() { this->id = Population::id_g++; } - - /** - * @brief Initialize values. Called once at the start of model run. - * - * @param nyears number of years in the population - * @param nseasons number of seasons in the population - * @param nages number of ages in the population - */ - void Initialize(int nyears, int nseasons, int nages) { - this->nyears = nyears; - this->nseasons = nseasons; - this->nages = nages; - - // size all the vectors to length of nages - nfleets = fleets.size(); - expected_catch.resize(nyears * nfleets); - years.resize(nyears); - mortality_F.resize(nyears * nages); - mortality_Z.resize(nyears * nages); - proportion_mature_at_age.resize((nyears + 1) * nages); - proportion_female.resize(nages); - weight_at_age.resize(nages); - unfished_numbers_at_age.resize((nyears + 1) * nages); - numbers_at_age.resize((nyears + 1) * nages); - biomass.resize((nyears + 1)); - unfished_biomass.resize((nyears + 1)); - unfished_spawning_biomass.resize((nyears + 1)); - spawning_biomass.resize((nyears + 1)); - expected_recruitment.resize((nyears + 1)); - M.resize(nyears * nages); - ages.resize(nages); - log_init_naa.resize(nages); - log_M.resize(nyears * nages); - } - - /** - * @brief Prepare to run the population loop. Called at each model iteration, - * and used to zero out derived quantities, values that were summed, etc. - * - */ - void Prepare() { - POPULATION_LOG << " population prepare " << this->nages << std::endl; - POPULATION_LOG << "nfleets: " << this->nfleets << std::endl; - POPULATION_LOG << "nseasons: " << this->nseasons << std::endl; - POPULATION_LOG << "nyears: " << this->nyears << std::endl; - - for (size_t fleet = 0; fleet < this->nfleets; fleet++) { - this->fleets[fleet]->Prepare(); - } - - std::fill(biomass.begin(), biomass.end(), 0.0); - std::fill(unfished_spawning_biomass.begin(), - unfished_spawning_biomass.end(), 0.0); - std::fill(spawning_biomass.begin(), spawning_biomass.end(), 0.0); - std::fill(expected_catch.begin(), expected_catch.end(), 0.0); - std::fill(expected_recruitment.begin(), expected_recruitment.end(), 0.0); - std::fill(proportion_mature_at_age.begin(), proportion_mature_at_age.end(), - 0.0); - std::fill(mortality_Z.begin(), mortality_Z.end(), 0.0); - std::fill(proportion_female.begin(), proportion_female.end(), 0.5); - - // Transformation Section - for (size_t age = 0; age < this->nages; age++) { - this->weight_at_age[age] = growth->evaluate(ages[age]); - for (size_t year = 0; year < this->nyears; year++) { - size_t i_age_year = age * this->nyears + year; - this->M[i_age_year] = fims_math::exp(this->log_M[i_age_year]); - // mortality_F is a fims::Vector and therefore needs to be filled - // within a loop - this->mortality_F[i_age_year] = 0.0; - } - } - } - - /** - * life history calculations - */ - - /** - * @brief Calculates initial numbers at age for index and age - * - * @param i_age_year dimension folded index for age and year - * @param a age index - */ - inline void CalculateInitialNumbersAA( - size_t i_age_year, size_t a) { // inline all function unless complicated - this->numbers_at_age[i_age_year] = fims_math::exp(this->log_init_naa[a]); - } - - /** - * @brief Calculates total mortality at an index, year, and age - * - * @param i_age_year dimension folded index for age and year - * @param year year index - * @param age age index - */ - void CalculateMortality(size_t i_age_year, size_t year, size_t age) { - for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { - if (this->fleets[fleet_]->is_survey == false) { - this->mortality_F[i_age_year] += - this->fleets[fleet_]->Fmort[year] * - // evaluate is a member function of the selectivity class - this->fleets[fleet_]->selectivity->evaluate(ages[age]); - POPULATION_LOG << " selectivity at age " << ages[age] << " for fleet " - << fleet_ << " is " - << this->fleets[fleet_]->selectivity->evaluate(ages[age]) - << " apical fishing mortality F for the fleet in year " - << year << " is " << this->fleets[fleet_]->Fmort[year] - << std::endl; - } - } - POPULATION_LOG << "M in calculate mortality is " << this->M[i_age_year] - << std::endl; - this->mortality_Z[i_age_year] = - this->M[i_age_year] + this->mortality_F[i_age_year]; - } - - /** - * @brief Calculates numbers at age at year and age specific indices - * - * @param i_age_year dimension folded index for age and year - * @param i_agem1_yearm1 dimension folded index for age-1 and year-1 - * @param age age index - */ - inline void CalculateNumbersAA(size_t i_age_year, size_t i_agem1_yearm1, - size_t age) { - // using Z from previous age/year - this->numbers_at_age[i_age_year] = - this->numbers_at_age[i_agem1_yearm1] * - - (fims_math::exp(-this->mortality_Z[i_agem1_yearm1])); - POPULATION_LOG << " z at i_agem1_yearm1 = " << i_agem1_yearm1 << " is " - << this->mortality_Z[i_agem1_yearm1] << std::endl; - // Plus group calculation - if (age == (this->nages - 1)) { - this->numbers_at_age[i_age_year] = - this->numbers_at_age[i_age_year] + - this->numbers_at_age[i_agem1_yearm1 + 1] * - (fims_math::exp(-this->mortality_Z[i_agem1_yearm1 + 1])); - } - } - - /** - * @brief Calculates unfished numbers at age at year and age specific indices - * - * @param i_age_year dimension folded index for age and year - * @param i_agem1_yearm1 dimension folded index for age-1 and year-1 - * @param age age index - */ - inline void CalculateUnfishedNumbersAA(size_t i_age_year, - size_t i_agem1_yearm1, size_t age) { - // using M from previous age/year - this->unfished_numbers_at_age[i_age_year] = - this->unfished_numbers_at_age[i_agem1_yearm1] * - - (fims_math::exp(-this->M[i_agem1_yearm1])); - POPULATION_LOG << "survival rate at index " << i_agem1_yearm1 << " is " - << fims_math::exp(-(this->M[i_agem1_yearm1])) << std::endl; - - // Plus group calculation - if (age == (this->nages - 1)) { - this->unfished_numbers_at_age[i_age_year] = - this->unfished_numbers_at_age[i_age_year] + - this->unfished_numbers_at_age[i_agem1_yearm1 + 1] * - (fims_math::exp(-this->M[i_agem1_yearm1 + 1])); - } - } - - /** - * @brief Calculates biomass - * - * @param i_age_year dimension folded index for age and year - * @param year the year biomass is being aggregated for - * @param age the age who's biomass is being added into total biomass - */ - void CalculateBiomass(size_t i_age_year, size_t year, size_t age) { - this->biomass[year] += - this->numbers_at_age[i_age_year] * this->weight_at_age[age]; - POPULATION_LOG << " age " << ages[age] << std::endl; - POPULATION_LOG << "growth evaluate: " << this->weight_at_age[age] - << " biomass inputs----- +++\n"; - } - - /** - * @brief Adds to existing yearly unfished biomass estimates the - * biomass for a specified year and age - * - * @param i_age_year dimension folded index for age and year - * @param year the year of unfished biomass to add - * @param age the age of unfished biomass to add - */ - void CalculateUnfishedBiomass(size_t i_age_year, size_t year, size_t age) { - this->unfished_biomass[year] += - this->unfished_numbers_at_age[i_age_year] * this->weight_at_age[age]; - } - - /** - * @brief Calculates spawning biomass - * - * @param i_age_year dimension folded index for age and year - * @param year the year spawning biomass is being aggregated for - * @param age the age who's biomass is being added into total spawning biomass - */ - void CalculateSpawningBiomass(size_t i_age_year, size_t year, size_t age) { - this->spawning_biomass[year] += - this->proportion_female[age] * this->numbers_at_age[i_age_year] * - this->proportion_mature_at_age[i_age_year] * this->weight_at_age[age]; - POPULATION_LOG << " proportion female " << this->proportion_female[age] - << " " - << " mature age " << age << " is " - << this->proportion_mature_at_age[i_age_year] << " " - << " numbers at age " << this->numbers_at_age[i_age_year] - << " " - << " growth " << this->weight_at_age[age] << " " - << " spawning biomass " << this->spawning_biomass[year] - << " " - << " spawning biomass inputs----- +++\n"; - } - - /** - * @brief Adds to existing yearly unfished spawning biomass estimates the - * biomass for a specified year and age - * - * @param i_age_year dimension folded index for age and year - * @param year the year of unfished spawning biomass to add - * @param age the age of unfished spawning biomass to add - */ - void CalculateUnfishedSpawningBiomass(size_t i_age_year, size_t year, - size_t age) { - this->unfished_spawning_biomass[year] += - this->proportion_female[age] * - this->unfished_numbers_at_age[i_age_year] * - this->proportion_mature_at_age[i_age_year] * this->weight_at_age[age]; - } - - /** - * @brief Calculates equilibrium spawning biomass per recruit - * - * @return Type - */ - Type CalculateSBPR0() { - std::vector numbers_spr(this->nages, 1.0); - Type phi_0 = 0.0; - phi_0 += numbers_spr[0] * this->proportion_female[0] * - this->proportion_mature_at_age[0] * - this->growth->evaluate(ages[0]); - for (size_t a = 1; a < (this->nages - 1); a++) { - numbers_spr[a] = numbers_spr[a - 1] * fims_math::exp(-this->M[a]); - phi_0 += numbers_spr[a] * this->proportion_female[a] * - this->proportion_mature_at_age[a] * - this->growth->evaluate(ages[a]); - } - - numbers_spr[this->nages - 1] = - (numbers_spr[nages - 2] * fims_math::exp(-this->M[nages - 2])) / - (1 - fims_math::exp(-this->M[this->nages - 1])); - phi_0 += numbers_spr[this->nages - 1] * - this->proportion_female[this->nages - 1] * - this->proportion_mature_at_age[this->nages - 1] * - this->growth->evaluate(ages[this->nages - 1]); - return phi_0; - } - - /** - * @brief Calculates expected recruitment for a given year - * - * @param i_age_year dimension folded index for age and year - * @param year the year recruitment is being calculated for - * @param i_dev index to log_recruit_dev of vector length nyears-1 - */ - void CalculateRecruitment(size_t i_age_year, size_t year, size_t i_dev) { - POPULATION_LOG << "recruitment 1" << std::endl; - Type phi0 = CalculateSBPR0(); - POPULATION_LOG << "recruitment 2" << std::endl; - POPULATION_LOG << "phi0 = " << phi0 << std::endl; - POPULATION_LOG << "spawning_biomass[year - 1] = " - << this->spawning_biomass[year - 1] << std::endl; - POPULATION_LOG << "log recruit devs = " - << this->recruitment->log_recruit_devs[i_dev - 1] - << std::endl; - POPULATION_LOG << "rec eval = " - << this->recruitment->evaluate( - this->spawning_biomass[year - 1], phi0) - << std::endl; - if (i_dev == this->nyears) { - this->numbers_at_age[i_age_year] = - this->recruitment->evaluate(this->spawning_biomass[year - 1], phi0); - /*the final year of the time series has no data to inform recruitment - devs, so this value is set to the mean recruitment.*/ - } else { - this->numbers_at_age[i_age_year] = - this->recruitment->evaluate(this->spawning_biomass[year - 1], phi0) * - /*the log_recruit_dev vector does not include a value for year == 0 - and is of length nyears - 1 where the first position of the vector - corresponds to the second year of the time series.*/ - fims_math::exp(this->recruitment->log_recruit_devs[i_dev - 1]); - this->expected_recruitment[year] = this->numbers_at_age[i_age_year]; - } - POPULATION_LOG << " numbers at age at index i_age_year " << i_age_year - << " is " << this->numbers_at_age[i_age_year] << std::endl; - } - - /** - * @brief Adds to exiting expected total catch by fleet in weight - * - * @param year the year of expected total catch - * @param age the age of catch that is being added into total catch - */ - void CalculateCatch(size_t year, size_t age) { - for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { - if (this->fleets[fleet_]->is_survey == false) { - size_t index_yf = year * this->nfleets + - fleet_; // index by fleet and years to dimension fold - size_t i_age_year = year * this->nages + age; - - POPULATION_LOG << " fleet " << fleet_ << " year " << year << " age " - << age << std::endl; - this->expected_catch[index_yf] += - this->fleets[fleet_]->catch_weight_at_age[i_age_year]; - - POPULATION_LOG << "expected catch: " << this->expected_catch[index_yf] - << std::endl; - POPULATION_LOG << "----------------------------------------------" - << std::endl; - - fleets[fleet_]->expected_catch[year] += - this->fleets[fleet_]->catch_weight_at_age[i_age_year]; - } - } - } - - /** - * @brief Adds to the expected population indices by fleet - * - * @param i_age_year dimension folded index for age and year - * @param year the year of the population index - * @param age the age of the index that is added into population index - */ - void CalculateIndex(size_t i_age_year, size_t year, size_t age) { - for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { - Type index_; - // I = qN (N is total numbers), I is an index in numbers - if (this->fleets[fleet_]->is_survey == false) { - index_ = this->fleets[fleet_]->catch_numbers_at_age[i_age_year] * - this->weight_at_age[age]; - } else { - POPULATION_LOG << "fleet " << fleet_ << " is a survey" << std::endl; - index_ = this->fleets[fleet_]->q * - this->fleets[fleet_]->selectivity->evaluate(ages[age]) * - this->numbers_at_age[i_age_year] * - this->weight_at_age[age]; // this->weight_at_age[age]; - } - fleets[fleet_]->expected_index[year] += index_; - POPULATION_LOG << " expected index in year " << year << " is " - << fleets[fleet_]->expected_index[year] << std::endl; - } - } - - /** - * @brief Calculates catch in numbers at age for each fleet for a given year - * and age, then adds the value to the expected catch in numbers at age for - * each fleet - * - * @param i_age_year dimension folded index for age and year - * @param year the year of expected catch composition is being calculated for - * @param age the age composition is being calculated for - */ - void CalculateCatchNumbersAA(size_t i_age_year, size_t year, size_t age) { - for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { - // make an intermediate value in order to set multiple members (of - // current and fleet objects) to that value. - Type catch_; // catch_ is used to avoid using the c++ keyword catch - // Baranov Catch Equation - if (this->fleets[fleet_]->is_survey == false) { - catch_ = (this->fleets[fleet_]->Fmort[year] * - this->fleets[fleet_]->selectivity->evaluate(ages[age])) / - this->mortality_Z[i_age_year] * - this->numbers_at_age[i_age_year] * - (1 - fims_math::exp(-(this->mortality_Z[i_age_year]))); - } else { - catch_ = (this->fleets[fleet_]->selectivity->evaluate(ages[age])) * - this->numbers_at_age[i_age_year]; - } - POPULATION_LOG << " F " << fleet_ << " " - << this->fleets[fleet_]->Fmort[year] << std::endl; - POPULATION_LOG << " selectivity " - << this->fleets[fleet_]->selectivity->evaluate(ages[age]) - << std::endl; - POPULATION_LOG << " catch " << catch_ << std::endl; - // this->catch_numbers_at_age[i_age_yearf] += catch_; - // catch_numbers_at_age for the fleet module has different - // dimensions (year/age, not year/fleet/age) - this->fleets[fleet_]->catch_numbers_at_age[i_age_year] += catch_; - } - } - - /** - * @brief Calculates expected catch weight at age for each fleet for a given - * year and age - * - * @param year the year of expected catch weight at age - * @param age the age of expected catch weight at age - */ - void CalculateCatchWeightAA(size_t year, size_t age) { - int i_age_year = year * this->nages + age; - for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { - POPULATION_LOG << " fleet " << fleet_ << std::endl; - POPULATION_LOG << " catchnaa " - << this->fleets[fleet_]->catch_numbers_at_age[year] - << std::endl; - POPULATION_LOG << " weight " << this->weight_at_age[age] << std::endl; - this->fleets[fleet_]->catch_weight_at_age[i_age_year] = - this->fleets[fleet_]->catch_numbers_at_age[i_age_year] * - this->weight_at_age[age]; - POPULATION_LOG << " catch_waa " - << this->fleets[fleet_]->catch_weight_at_age[i_age_year] - << std::endl; - } - } - - /** - * @brief Calculates expected proportion of individuals mature at a selected - * ageage - * - * @param i_age_year dimension folded index for age and year - * @param age the age of maturity - */ - void CalculateMaturityAA(size_t i_age_year, size_t age) { - // this->maturity is pointing to the maturity module, which has - // an evaluate function. -> can be nested. - POPULATION_LOG << " age " << age << std::endl; - POPULATION_LOG << " ages size " << this->ages.size() << std::endl; - POPULATION_LOG << " i_age_year " << i_age_year << std::endl; - POPULATION_LOG << "p mature" << this->proportion_mature_at_age[i_age_year] - << std::endl; - POPULATION_LOG << this->ages[age] << std::endl; - this->proportion_mature_at_age[i_age_year] = - this->maturity->evaluate(ages[age]); - - POPULATION_LOG << "p mature set to " - << this->proportion_mature_at_age[i_age_year] << std::endl; - } - - /** - * @brief Executes the population loop - * - */ - void Evaluate() { - /* - Sets derived vectors to zero - Performs parameters transformations - Sets recruitment deviations to mean 0. - */ - Prepare(); - /* - start at year=0, age=0; - here year 0 is the estimated initial stock structure and age 0 are recruits - loops start at zero with if statements inside to specify unique code for - initial structure and recruitment 0 loops. Could also have started loops at - 1 with initial structure and recruitment setup outside the loops. - - year loop is extended to <= nyears because SSB is calculted as the start of - the year value and by extending one extra year we get estimates of the - population structure at the end of the final year. An alternative approach - would be to keep initial numbers at age in it's own vector and each year to - include the population structure at the end of the year. This is likely a - null point given that we are planning to modify to an event/stanza based - structure in later milestones which will elimitate this confusion by - explicity referencing the exact date (or period of averaging) at which any - calculation or output is being made. - */ - for (size_t y = 0; y <= this->nyears; y++) { - for (size_t a = 0; a < this->nages; a++) { - /* - index naming defines the dimensional folding structure - i.e. i_age_year is referencing folding over years and ages. + // this -> means you're referring to a class member (member of self) + + Population() { + this->id = Population::id_g++; + } + + /** + * @brief Initialize values. Called once at the start of model run. + * + * @param nyears number of years in the population + * @param nseasons number of seasons in the population + * @param nages number of ages in the population */ - size_t i_age_year = y * this->nages + a; - /* - Mortality rates are not estimated in the final year which is - used to show expected stock structure at the end of the model period. - This is because biomass in year i represents biomass at the start of - the year. - Should we add complexity to track more values such as start, - mid, and end biomass in all years where, start biomass=end biomass of - the previous year? Referenced above, this is probably not worth - exploring as later milestone changes will eliminate this confusion. + void Initialize(int nyears, int nseasons, int nages) { + this->nyears = nyears; + this->nseasons = nseasons; + this->nages = nages; + + // size all the vectors to length of nages + nfleets = fleets.size(); + expected_catch.resize(nyears * nfleets); + years.resize(nyears); + mortality_F.resize(nyears * nages); + mortality_Z.resize(nyears * nages); + proportion_mature_at_age.resize((nyears + 1) * nages); + proportion_female.resize(nages); + weight_at_age.resize(nages); + unfished_numbers_at_age.resize((nyears + 1) * nages); + biomass.resize((nyears + 1)); + unfished_biomass.resize((nyears + 1)); + unfished_spawning_biomass.resize((nyears + 1)); + spawning_biomass.resize((nyears + 1)); + expected_recruitment.resize((nyears + 1)); + M.resize(nyears * nages); + ages.resize(nages); + log_init_naa.resize(nages); + log_M.resize(nyears * nages); + } + + /** + * @brief Prepare to run the population loop. Called at each model iteration, + * and used to zero out derived quantities, values that were summed, etc. + * */ - if (y < this->nyears) { - /* - First thing we need is total mortality aggregated across all fleets - to inform the subsequent catch and change in numbers at age - calculations. This is only calculated for years < nyears as these are - the model estimated years with data. The year loop extends to - y=nyears so that population numbers at age and SSB can be calculated - at the end of the last year of the model - */ - CalculateMortality(i_age_year, y, a); + void Prepare() { + + for (size_t fleet = 0; fleet < this->fleets.size(); fleet++) { + this->fleets[fleet]->Prepare(); + } + + std::fill(biomass.begin(), biomass.end(), 0.0); + std::fill(unfished_spawning_biomass.begin(), + unfished_spawning_biomass.end(), 0.0); + std::fill(spawning_biomass.begin(), spawning_biomass.end(), 0.0); + std::fill(expected_catch.begin(), expected_catch.end(), 0.0); + std::fill(expected_recruitment.begin(), expected_recruitment.end(), 0.0); + std::fill(proportion_mature_at_age.begin(), proportion_mature_at_age.end(), + 0.0); + std::fill(mortality_Z.begin(), mortality_Z.end(), 0.0); + std::fill(proportion_female.begin(), proportion_female.end(), 0.5); + + // Transformation Section + for (size_t age = 0; age < this->nages; age++) { + this->weight_at_age[age] = growth->evaluate(ages[age]); + for (size_t year = 0; year < this->nyears; year++) { + size_t i_age_year = age * this->nyears + year; + this->M[i_age_year] = fims_math::exp(this->log_M[i_age_year]); + // mortality_F is a fims::Vector and therefore needs to be filled + // within a loop + this->mortality_F[i_age_year] = 0.0; + } + } } - CalculateMaturityAA(i_age_year, a); - /* if statements needed because some quantities are only needed - for the first year and/or age, so these steps are included here. + + /** + * life history calculations */ - if (y == 0) { - // Initial numbers at age is a user input or estimated parameter - // vector. - CalculateInitialNumbersAA(i_age_year, a); - if (a == 0) { - // this->numbers_at_age[i_age_year] = this->recruitment->rzero; + /** + * @brief Calculates initial numbers at age for index and age + * + * @param i_age_year dimension folded index for age and year + * @param a age index + */ + inline void CalculateInitialNumbersAA( + size_t i_age_year, size_t a) { // inline all function unless complicated + this->numbers_at_age[i_age_year] = fims_math::exp(this->log_init_naa[a]); + } + + /** + * @brief Calculates total mortality at an index, year, and age + * + * @param i_age_year dimension folded index for age and year + * @param year year index + * @param age age index + */ + void CalculateMortality(size_t i_age_year, size_t year, size_t age) { + for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { + if (this->fleets[fleet_]->is_survey == false) { + this->mortality_F[i_age_year] += + this->fleets[fleet_]->Fmort[year] * + // evaluate is a member function of the selectivity class + this->fleets[fleet_]->selectivity->evaluate(ages[age]); + + } + } + + this->mortality_Z[i_age_year] = + this->M[i_age_year] + this->mortality_F[i_age_year]; + } + + /** + * @brief Calculates numbers at age at year and age specific indices + * + * @param i_age_year dimension folded index for age and year + * @param i_agem1_yearm1 dimension folded index for age-1 and year-1 + * @param age age index + */ + inline void CalculateNumbersAA(size_t i_age_year, size_t i_agem1_yearm1, + size_t age) { + // using Z from previous age/year + this->numbers_at_age[i_age_year] = + this->numbers_at_age[i_agem1_yearm1] * + (fims_math::exp(-this->mortality_Z[i_agem1_yearm1])); + + // Plus group calculation + if (age == (this->nages - 1)) { + this->numbers_at_age[i_age_year] = + this->numbers_at_age[i_age_year] + + this->numbers_at_age[i_agem1_yearm1 + 1] * + (fims_math::exp(-this->mortality_Z[i_agem1_yearm1 + 1])); + } + } + + /** + * @brief Calculates unfished numbers at age at year and age specific indices + * + * @param i_age_year dimension folded index for age and year + * @param i_agem1_yearm1 dimension folded index for age-1 and year-1 + * @param age age index + */ + inline void CalculateUnfishedNumbersAA(size_t i_age_year, + size_t i_agem1_yearm1, size_t age) { + // using M from previous age/year this->unfished_numbers_at_age[i_age_year] = - fims_math::exp(this->recruitment->log_rzero); - } else { - CalculateUnfishedNumbersAA(i_age_year, a - 1, a); - } + this->unfished_numbers_at_age[i_agem1_yearm1] * - /* - Fished and unfished biomass vectors are summing biomass at - age across ages. - */ + (fims_math::exp(-this->M[i_agem1_yearm1])); - CalculateBiomass(i_age_year, y, a); + // Plus group calculation + if (age == (this->nages - 1)) { + this->unfished_numbers_at_age[i_age_year] = + this->unfished_numbers_at_age[i_age_year] + + this->unfished_numbers_at_age[i_agem1_yearm1 + 1] * + (fims_math::exp(-this->M[i_agem1_yearm1 + 1])); + } + } - CalculateUnfishedBiomass(i_age_year, y, a); + /** + * @brief Calculates biomass + * + * @param i_age_year dimension folded index for age and year + * @param year the year biomass is being aggregated for + * @param age the age who's biomass is being added into total biomass + */ + void CalculateBiomass(size_t i_age_year, size_t year, size_t age) { + this->biomass[year] += + this->numbers_at_age[i_age_year] * this->weight_at_age[age]; + } - /* - Fished and unfished spawning biomass vectors are summing biomass at - age across ages to allow calculation of recruitment in the next year. - */ + /** + * @brief Adds to existing yearly unfished biomass estimates the + * biomass for a specified year and age + * + * @param i_age_year dimension folded index for age and year + * @param year the year of unfished biomass to add + * @param age the age of unfished biomass to add + */ + void CalculateUnfishedBiomass(size_t i_age_year, size_t year, size_t age) { + this->unfished_biomass[year] += + this->unfished_numbers_at_age[i_age_year] * this->weight_at_age[age]; + } - CalculateSpawningBiomass(i_age_year, y, a); + /** + * @brief Calculates spawning biomass + * + * @param i_age_year dimension folded index for age and year + * @param year the year spawning biomass is being aggregated for + * @param age the age who's biomass is being added into total spawning biomass + */ + void CalculateSpawningBiomass(size_t i_age_year, size_t year, size_t age) { + this->spawning_biomass[year] += + this->proportion_female[age] * this->numbers_at_age[i_age_year] * + this->proportion_mature_at_age[i_age_year] * this->weight_at_age[age]; + } + + /** + * @brief Adds to existing yearly unfished spawning biomass estimates the + * biomass for a specified year and age + * + * @param i_age_year dimension folded index for age and year + * @param year the year of unfished spawning biomass to add + * @param age the age of unfished spawning biomass to add + */ + void CalculateUnfishedSpawningBiomass(size_t i_age_year, size_t year, + size_t age) { + this->unfished_spawning_biomass[year] += + this->proportion_female[age] * + this->unfished_numbers_at_age[i_age_year] * + this->proportion_mature_at_age[i_age_year] * this->weight_at_age[age]; + } + + /** + * @brief Calculates equilibrium spawning biomass per recruit + * + * @return Type + */ + Type CalculateSBPR0() { + std::vector numbers_spr(this->nages, 1.0); + Type phi_0 = 0.0; + phi_0 += numbers_spr[0] * this->proportion_female[0] * + this->proportion_mature_at_age[0] * + this->growth->evaluate(ages[0]); + for (size_t a = 1; a < (this->nages - 1); a++) { + numbers_spr[a] = numbers_spr[a - 1] * fims_math::exp(-this->M[a]); + phi_0 += numbers_spr[a] * this->proportion_female[a] * + this->proportion_mature_at_age[a] * + this->growth->evaluate(ages[a]); + } + + numbers_spr[this->nages - 1] = + (numbers_spr[nages - 2] * fims_math::exp(-this->M[nages - 2])) / + (1 - fims_math::exp(-this->M[this->nages - 1])); + phi_0 += numbers_spr[this->nages - 1] * + this->proportion_female[this->nages - 1] * + this->proportion_mature_at_age[this->nages - 1] * + this->growth->evaluate(ages[this->nages - 1]); + return phi_0; + } - CalculateUnfishedSpawningBiomass(i_age_year, y, a); + /** + * @brief Calculates expected recruitment for a given year + * + * @param i_age_year dimension folded index for age and year + * @param year the year recruitment is being calculated for + * @param i_dev index to log_recruit_dev of vector length nyears-1 + */ + void CalculateRecruitment(size_t i_age_year, size_t year, size_t i_dev) { + Type phi0 = CalculateSBPR0(); + + if (i_dev == this->nyears) { + this->numbers_at_age[i_age_year] = + this->recruitment->evaluate(this->spawning_biomass[year - 1], phi0); + /*the final year of the time series has no data to inform recruitment + devs, so this value is set to the mean recruitment.*/ + } else { + this->numbers_at_age[i_age_year] = + this->recruitment->evaluate(this->spawning_biomass[year - 1], phi0) * + /*the log_recruit_dev vector does not include a value for year == 0 + and is of length nyears - 1 where the first position of the vector + corresponds to the second year of the time series.*/ + fims_math::exp(this->recruitment->log_recruit_devs[i_dev - 1]); + this->expected_recruitment[year] = this->numbers_at_age[i_age_year]; + } - /* - Expected recruitment in year 0 is numbers at age 0 in year 0. - */ + } - this->expected_recruitment[i_age_year] = - this->numbers_at_age[i_age_year]; + /** + * @brief Adds to exiting expected total catch by fleet in weight + * + * @param year the year of expected total catch + * @param age the age of catch that is being added into total catch + */ + void CalculateCatch(size_t year, size_t age) { + for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { + if (this->fleets[fleet_]->is_survey == false) { + size_t index_yf = year * this->nfleets + + fleet_; // index by fleet and years to dimension fold + size_t i_age_year = year * this->nages + age; + + this->expected_catch[index_yf] += + this->fleets[fleet_]->catch_weight_at_age[i_age_year]; + + fleets[fleet_]->expected_catch[year] += + this->fleets[fleet_]->catch_weight_at_age[i_age_year]; + } + } + } - } else { - if (a == 0) { - // Set the nrecruits for age a=0 year y (use pointers instead of - // functional returns) assuming fecundity = 1 and 50:50 sex ratio - POPULATION_LOG << "Recruitment: " << std::endl; - CalculateRecruitment(i_age_year, y, y); - this->unfished_numbers_at_age[i_age_year] = - fims_math::exp(this->recruitment->log_rzero); - - } else { - size_t i_agem1_yearm1 = (y - 1) * nages + (a - 1); - CalculateNumbersAA(i_age_year, i_agem1_yearm1, a); - CalculateUnfishedNumbersAA(i_age_year, i_agem1_yearm1, a); - } - CalculateBiomass(i_age_year, y, a); - CalculateSpawningBiomass(i_age_year, y, a); - - POPULATION_LOG << "index age year: " << i_age_year << std::endl; - CalculateUnfishedBiomass(i_age_year, y, a); - CalculateUnfishedSpawningBiomass(i_age_year, y, a); + /** + * @brief Adds to the expected population indices by fleet + * + * @param i_age_year dimension folded index for age and year + * @param year the year of the population index + * @param age the age of the index that is added into population index + */ + void CalculateIndex(size_t i_age_year, size_t year, size_t age) { + for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { + Type index_; + // I = qN (N is total numbers), I is an index in numbers + if (this->fleets[fleet_]->is_survey == false) { + index_ = this->fleets[fleet_]->catch_numbers_at_age[i_age_year] * + this->weight_at_age[age]; + } else { + index_ = this->fleets[fleet_]->q.get_force_scalar(year) * + this->fleets[fleet_]->selectivity->evaluate(ages[age]) * + this->numbers_at_age[i_age_year] * + this->weight_at_age[age]; // this->weight_at_age[age]; + } + fleets[fleet_]->expected_index[year] += index_; + } } - /* - Here composition, total catch, and index values are calculated for all - years with reference data. They are not calculated for y=nyears as there - is this is just to get final population structure at the end of the - terminal year. + /** + * @brief Calculates catch in numbers at age for each fleet for a given year + * and age, then adds the value to the expected catch in numbers at age for + * each fleet + * + * @param i_age_year dimension folded index for age and year + * @param year the year of expected catch composition is being calculated for + * @param age the age composition is being calculated for */ - if (y < this->nyears) { - POPULATION_LOG << i_age_year << std::endl; - CalculateCatchNumbersAA(i_age_year, y, a); - - CalculateCatchWeightAA(y, a); - POPULATION_LOG << "year " << y << " and age " << a << std::endl; - CalculateCatch(y, a); - CalculateIndex(i_age_year, y, a); + void CalculateCatchNumbersAA(size_t i_age_year, size_t year, size_t age) { + for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { + // make an intermediate value in order to set multiple members (of + // current and fleet objects) to that value. + Type catch_; // catch_ is used to avoid using the c++ keyword catch + // Baranov Catch Equation + if (this->fleets[fleet_]->is_survey == false) { + catch_ = (this->fleets[fleet_]->Fmort[year] * + this->fleets[fleet_]->selectivity->evaluate(ages[age])) / + this->mortality_Z[i_age_year] * + this->numbers_at_age[i_age_year] * + (1 - fims_math::exp(-(this->mortality_Z[i_age_year]))); + } else { + catch_ = (this->fleets[fleet_]->selectivity->evaluate(ages[age])) * + this->numbers_at_age[i_age_year]; + } + + // this->catch_numbers_at_age[i_age_yearf] += catch_; + // catch_numbers_at_age for the fleet module has different + // dimensions (year/age, not year/fleet/age) + this->fleets[fleet_]->catch_numbers_at_age[i_age_year] += catch_; + } } - } - } - - POPULATION_LOG << "NAA\n"; - for (size_t i = 0; i < nyears; i++) { - for (size_t j = 0; j < nages; j++) { - POPULATION_LOG << numbers_at_age[i * nages + j] << "\t"; - } - POPULATION_LOG << "\n"; - } - - POPULATION_LOG << "CAA\n"; - for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { - for (size_t i = 0; i < nyears; i++) { - for (size_t j = 0; j < nages; j++) { - POPULATION_LOG << "Fleet " << fleet_ + 1 << "\n"; - POPULATION_LOG << fleets[fleet_]->catch_numbers_at_age[i * nages + j] - << "\t"; + + /** + * @brief Calculates expected catch weight at age for each fleet for a given + * year and age + * + * @param year the year of expected catch weight at age + * @param age the age of expected catch weight at age + */ + void CalculateCatchWeightAA(size_t year, size_t age) { + int i_age_year = year * this->nages + age; + for (size_t fleet_ = 0; fleet_ < this->nfleets; fleet_++) { + + this->fleets[fleet_]->catch_weight_at_age[i_age_year] = + this->fleets[fleet_]->catch_numbers_at_age[i_age_year] * + this->weight_at_age[age]; + + } + } + + /** + * @brief Calculates expected proportion of individuals mature at a selected + * ageage + * + * @param i_age_year dimension folded index for age and year + * @param age the age of maturity + */ + void CalculateMaturityAA(size_t i_age_year, size_t age) { + // this->maturity is pointing to the maturity module, which has + // an evaluate function. -> can be nested. + + this->proportion_mature_at_age[i_age_year] = + this->maturity->evaluate(ages[age]); + } - POPULATION_LOG << "\n"; - } - } - } -}; -template -uint32_t Population::id_g = 0; - -} // namespace fims_popdy + + /** + * @brief Executes the population loop + * + */ + void Evaluate() { + /* + Sets derived vectors to zero + Performs parameters transformations + Sets recruitment deviations to mean 0. + */ + Prepare(); + /* + start at year=0, age=0; + here year 0 is the estimated initial population structure and age 0 are recruits + loops start at zero with if statements inside to specify unique code for + initial structure and recruitment 0 loops. Could also have started loops at + 1 with initial structure and recruitment setup outside the loops. + + year loop is extended to <= nyears because SSB is calculted as the start of + the year value and by extending one extra year we get estimates of the + population structure at the end of the final year. An alternative approach + would be to keep initial numbers at age in it's own vector and each year to + include the population structure at the end of the year. This is likely a + null point given that we are planning to modify to an event/stanza based + structure in later milestones which will elimitate this confusion by + explicity referencing the exact date (or period of averaging) at which any + calculation or output is being made. + */ + for (size_t y = 0; y <= this->nyears; y++) { + for (size_t a = 0; a < this->nages; a++) { + /* + index naming defines the dimensional folding structure + i.e. i_age_year is referencing folding over years and ages. + */ + size_t i_age_year = y * this->nages + a; + /* + Mortality rates are not estimated in the final year which is + used to show expected population structure at the end of the model period. + This is because biomass in year i represents biomass at the start of + the year. + Should we add complexity to track more values such as start, + mid, and end biomass in all years where, start biomass=end biomass of + the previous year? Referenced above, this is probably not worth + exploring as later milestone changes will eliminate this confusion. + */ + if (y < this->nyears) { + /* + First thing we need is total mortality aggregated across all fleets + to inform the subsequent catch and change in numbers at age + calculations. This is only calculated for years < nyears as these are + the model estimated years with data. The year loop extends to + y=nyears so that population numbers at age and SSB can be calculated + at the end of the last year of the model + */ + CalculateMortality(i_age_year, y, a); + } + CalculateMaturityAA(i_age_year, a); + /* if statements needed because some quantities are only needed + for the first year and/or age, so these steps are included here. + */ + if (y == 0) { + // Initial numbers at age is a user input or estimated parameter + // vector. + CalculateInitialNumbersAA(i_age_year, a); + + if (a == 0) { + this->unfished_numbers_at_age[i_age_year] = + fims_math::exp(this->recruitment->log_rzero[0]); + } else { + CalculateUnfishedNumbersAA(i_age_year, a - 1, a); + } + + /* + Fished and unfished biomass vectors are summing biomass at + age across ages. + */ + + CalculateBiomass(i_age_year, y, a); + + CalculateUnfishedBiomass(i_age_year, y, a); + + /* + Fished and unfished spawning biomass vectors are summing biomass at + age across ages to allow calculation of recruitment in the next year. + */ + + CalculateSpawningBiomass(i_age_year, y, a); + + CalculateUnfishedSpawningBiomass(i_age_year, y, a); + + /* + Expected recruitment in year 0 is numbers at age 0 in year 0. + */ + + this->expected_recruitment[i_age_year] = + this->numbers_at_age[i_age_year]; + + } else { + if (a == 0) { + // Set the nrecruits for age a=0 year y (use pointers instead of + // functional returns) assuming fecundity = 1 and 50:50 sex ratio + CalculateRecruitment(i_age_year, y, y); + this->unfished_numbers_at_age[i_age_year] = + fims_math::exp(this->recruitment->log_rzero[0]); + + } else { + size_t i_agem1_yearm1 = (y - 1) * nages + (a - 1); + CalculateNumbersAA(i_age_year, i_agem1_yearm1, a); + CalculateUnfishedNumbersAA(i_age_year, i_agem1_yearm1, a); + } + CalculateBiomass(i_age_year, y, a); + CalculateSpawningBiomass(i_age_year, y, a); + + CalculateUnfishedBiomass(i_age_year, y, a); + CalculateUnfishedSpawningBiomass(i_age_year, y, a); + } + + /* + Here composition, total catch, and index values are calculated for all + years with reference data. They are not calculated for y=nyears as there + is this is just to get final population structure at the end of the + terminal year. + */ + if (y < this->nyears) { + CalculateCatchNumbersAA(i_age_year, y, a); + + CalculateCatchWeightAA(y, a); + CalculateCatch(y, a); + CalculateIndex(i_age_year, y, a); + } + } + } + + } + }; + template + uint32_t Population::id_g = 0; + +} // namespace fims_popdy #endif /* FIMS_POPULATION_DYNAMICS_POPULATION_HPP */ diff --git a/inst/include/population_dynamics/population/subpopulation.hpp b/inst/include/population_dynamics/population/subpopulation.hpp index 9ccc7e6bb..5cf048747 100644 --- a/inst/include/population_dynamics/population/subpopulation.hpp +++ b/inst/include/population_dynamics/population/subpopulation.hpp @@ -1,32 +1,8 @@ -/* - * File: subpopulation.hpp - * - * Author: Matthew Supernaw, Andrea Havron - * National Oceanic and Atmospheric Administration - * National Marine Fisheries Service - * Email: matthew.supernaw@noaa.gov, andrea.havron@noaa.gov - * - * Created on September 30, 2021, 1:07 PM - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * - * This software is a "United States Government Work" under the terms of the - * United States Copyright Act. It was written as part of the author's official - * duties as a United States Government employee and thus cannot be copyrighted. - * This software is freely available to the public for use. The National Oceanic - * And Atmospheric Administration and the U.S. Government have not placed any - * restriction on its use or reproduction. Although all reasonable efforts have - * been taken to ensure the accuracy and reliability of the software and data, - * the National Oceanic And Atmospheric Administration and the U.S. Government - * do not and cannot warrant the performance or results that may be obtained by - * using this software or data. The National Oceanic And Atmospheric - * Administration and the U.S. Government disclaim all warranties, express or - * implied, including warranties of performance, merchantability or fitness - * for any particular purpose. - * - * Please cite the author(s) in any work or product based on this material. - * +/** + * @file subpopulation.hpp + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_POPULATION_SUBPOPULATION_HPP #define FIMS_POPULATION_DYNAMICS_POPULATION_SUBPOPULATION_HPP diff --git a/inst/include/population_dynamics/recruitment/functors/recruitment_base.hpp b/inst/include/population_dynamics/recruitment/functors/recruitment_base.hpp index bbec7f93a..3a6f65a86 100644 --- a/inst/include/population_dynamics/recruitment/functors/recruitment_base.hpp +++ b/inst/include/population_dynamics/recruitment/functors/recruitment_base.hpp @@ -1,15 +1,11 @@ -/** \file recruitment_base.hpp - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Recruitment base file - * The purpose of this file is to serve as the parent class where - * recruitment functions are called. - * - * DEFINE guards for recruitment base outline to define the +/** + * @file recruitment_base.hpp + * @brief Serves as the parent class where recruitment functions are called. + * @details Defines guards for recruitment base outline to define the * recruitment hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_RECRUITMENT_BASE_HPP #define FIMS_POPULATION_DYNAMICS_RECRUITMENT_BASE_HPP @@ -33,13 +29,11 @@ struct RecruitmentBase : public fims_model_object::FIMSObject { static uint32_t id_g; /**< reference id for recruitment object*/ fims::Vector - log_recruit_devs; /*!< A vector of log recruitment deviations */ + log_recruit_devs; /*!< A vector of the natural log of recruitment deviations */ bool constrain_deviations = false; /*!< A flag to indicate if recruitment deviations are summing to zero or not */ - Type log_sigma_recruit; /**< Log standard deviation of log recruitment - deviations */ - Type log_rzero; /**< Log of unexploited recruitment.*/ + fims::Vector log_rzero; /**< Natural log of unexploited recruitment.*/ bool estimate_log_recruit_devs = true; /*!< A flag to indicate if recruitment deviations are estimated or not */ @@ -66,27 +60,6 @@ struct RecruitmentBase : public fims_model_object::FIMSObject { const Type &spawners, const Type &ssbzero) = 0; // need to add input parameter values - /** @brief Calculates the negative log likelihood of recruitment deviations. - * - */ - virtual const Type evaluate_nll() { - Type nll = 0.0; /**< The negative log likelihood value */ - - if (!this->estimate_log_recruit_devs) { - return nll; - } else { -#ifdef TMB_MODEL - fims_distributions::Dnorm dnorm; - dnorm.sd = fims_math::exp(this->log_sigma_recruit); - for (size_t i = 0; i < this->log_recruit_devs.size(); i++) { - dnorm.x = this->log_recruit_devs[i]; - dnorm.mean = 0.0; - nll -= dnorm.evaluate(true); - } -#endif - return nll; - } - } /** @brief Prepare constrained recruitment deviations. * Based on ADMB sum-to-zero constraint implementation. We still @@ -105,10 +78,8 @@ struct RecruitmentBase : public fims_model_object::FIMSObject { sum += this->log_recruit_devs[i]; } - RECRUITMENT_LOG << "log_recruit_devs: \n"; for (size_t i = 0; i < this->log_recruit_devs.size(); i++) { this->log_recruit_devs[i] -= sum / (this->log_recruit_devs.size()); - RECRUITMENT_LOG << this->log_recruit_devs[i] << std::endl; } } }; diff --git a/inst/include/population_dynamics/recruitment/functors/sr_beverton_holt.hpp b/inst/include/population_dynamics/recruitment/functors/sr_beverton_holt.hpp index 81c4ed8a9..66407d109 100644 --- a/inst/include/population_dynamics/recruitment/functors/sr_beverton_holt.hpp +++ b/inst/include/population_dynamics/recruitment/functors/sr_beverton_holt.hpp @@ -1,43 +1,45 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Beverton Holt stock recruitment function - * The purpose of this file is to call the Beverton Holt stock - * recruitment function from fims_math and does the calculation. - * Inherits from recruitment base. - * +/** + * @file sr_beverton_holt.hpp + * @brief Calls the Beverton--Holt stock--recruitment function from fims_math + * and does the calculation. + * @details This function inherits from recruitment base. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_RECRUITMENT_SR_BEVERTON_HOLT_HPP #define FIMS_POPULATION_DYNAMICS_RECRUITMENT_SR_BEVERTON_HOLT_HPP #include "recruitment_base.hpp" +#include "../../../common/fims_vector.hpp" namespace fims_popdy { -/** @brief BevertonHolt class that returns the Beverton Holt SR - * from fims_math. +/** @brief BevertonHolt class that returns the Beverton--Holt + * stock--recruitment from fims_math. * - * @param logit_steep Recruitment relative to unfished recruitment at - * 20% of unfished spawning biomass. Should be a value between 0.2 and 1.0. + * @param logit_steep Recruitment relative to unfished recruitment at 20 + * percent of unfished spawning biomass. Steepness is subject to a logit + * transformation to keep it between 0.2 and 1.0. */ template struct SRBevertonHolt : public RecruitmentBase { - // Here we define the members that will be used in the Beverton Holt SR - // function. These members are needed by Beverton Holt but will not be common - // to all recruitment functions like spawners is below. - Type logit_steep; /**< Transformed value of recruitment relative to unfished - recruitment at 20% of unfished spawning biomass.*/ + // Here we define the members that will be used in the Beverton--Holt + // stock--recruitment function. These members are needed by the Beverton--Holt + // stock--recruitment function but will not be common to all recruitment + // functions like spawners is below. + fims::Vector logit_steep; /**< Transformed value of recruitment + relative to unfished + recruitment at 20 percent of unfished + spawning biomass.*/ SRBevertonHolt() : RecruitmentBase() {} virtual ~SRBevertonHolt() {} - /** @brief Beverton Holt implementation of the stock recruitment function. + /** @brief Beverton--Holt implementation of the stock--recruitment function. * - * The Beverton Holt stock recruitment implementation: + * The Beverton--Holt stock--recruitment implementation: * \f$ \frac{0.8 R_{0} h S_{t-1}}{0.2 R_{0} \phi_{0} (1 - h) + S_{t-1} (h - * 0.2)} \f$ * @@ -52,8 +54,8 @@ struct SRBevertonHolt : public RecruitmentBase { Type rzero; // Transform input parameters - steep = fims_math::inv_logit(steep_lo, steep_hi, this->logit_steep); - rzero = fims_math::exp(this->log_rzero); + steep = fims_math::inv_logit(steep_lo, steep_hi, this->logit_steep[0]); + rzero = fims_math::exp(this->log_rzero[0]); recruits = (0.8 * rzero * steep * spawners) / (0.2 * phi_0 * rzero * (1.0 - steep) + spawners * (steep - 0.2)); diff --git a/inst/include/population_dynamics/recruitment/recruitment.hpp b/inst/include/population_dynamics/recruitment/recruitment.hpp index 58714817b..c78a53822 100644 --- a/inst/include/population_dynamics/recruitment/recruitment.hpp +++ b/inst/include/population_dynamics/recruitment/recruitment.hpp @@ -1,15 +1,12 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Recruitment module file - * The purpose of this file is to include any .hpp files within the - * subfolders so that only this file needs to included in the model.hpp file. - * - * DEFINE guards for recruitment module outline to define the +/** + * @file recruitment.hpp + * @brief Includes any .hpp files within the subfolders so that only this file + * needs to included in the model.hpp file. + * @details Defines guards for recruitment module outline to define the * recruitment hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_RECRUITMENT_HPP #define FIMS_POPULATION_DYNAMICS_RECRUITMENT_HPP diff --git a/inst/include/population_dynamics/selectivity/functors/double_logistic.hpp b/inst/include/population_dynamics/selectivity/functors/double_logistic.hpp index 66d20375a..0a65f47f9 100644 --- a/inst/include/population_dynamics/selectivity/functors/double_logistic.hpp +++ b/inst/include/population_dynamics/selectivity/functors/double_logistic.hpp @@ -1,14 +1,17 @@ -/* - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. - * +/** + * @file logistic.hpp + * @brief Declares the DoubleLogisticSelectivity class which implements the + * logistic function from fims_math in the selectivity module. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef POPULATION_DYNAMICS_SELECTIVITY_DOUBLE_LOGISTIC_HPP #define POPULATION_DYNAMICS_SELECTIVITY_DOUBLE_LOGISTIC_HPP //#include "../../../interface/interface.hpp" #include "../../../common/fims_math.hpp" +#include "../../../common/fims_vector.hpp" #include "selectivity_base.hpp" namespace fims_popdy { @@ -19,39 +22,64 @@ namespace fims_popdy { */ template struct DoubleLogisticSelectivity : public SelectivityBase { - Type inflection_point_asc; /**< 50% quantile of the value of the quantity of + fims::Vector inflection_point_asc; /**< 50% quantile of the value of the quantity of interest (x) on the ascending limb of the double logistic curve; e.g. age at which 50% of the fish are selected */ - Type slope_asc; /** slope_asc; /** inflection_point_desc; /**< 50% quantile of the value of the quantity of interest (x) on the descending limb of the double logistic curve; e.g. age at which 50% of the fish are selected */ - Type slope_desc; /** slope_desc; /**() {} - - virtual ~DoubleLogisticSelectivity() {} - /** - * @brief Method of the double logistic selectivity class that implements the - * double logistic function from FIMS math. - * - * \f$ \frac{1.0}{ 1.0 + exp(-1.0 * slope_{asc} (x - inflection_point_{asc}))} - * \left(1.0-\frac{1.0}{ 1.0 + exp(-1.0 * slope_{desc} (x - - * inflection_point_{desc}))} \right)\f$ - * - * @param x The independent variable in the double logistic function (e.g., - * age or size in selectivity). - */ - virtual const Type evaluate(const Type &x) { - return fims_math::double_logistic( - inflection_point_asc, slope_asc, inflection_point_desc, slope_desc, x); - } + DoubleLogisticSelectivity() : SelectivityBase() + { + } + + virtual ~DoubleLogisticSelectivity() + { + } + + /** + * @brief Method of the double logistic selectivity class that implements the + * double logistic function from FIMS math. + * + * \f$ \frac{1.0}{ 1.0 + exp(-1.0 * slope\_asc (x - inflection_point\_asc))} + * \left(1.0-\frac{1.0}{ 1.0 + exp(-1.0 * slope\_desc (x - + * inflection_point\_desc))} \right)\f$ + * + * @param x The independent variable in the double logistic function (e.g., + * age or size in selectivity). + */ + virtual const Type evaluate(const Type &x) + { + return fims_math::double_logistic( + inflection_point_asc[0], slope_asc[0], inflection_point_desc[0], slope_desc[0], x); + } + + /** + * @brief Method of the double logistic selectivity class that implements the + * double logistic function from FIMS math. + * + * \f$ \frac{1.0}{ 1.0 + exp(-1.0 * slope\_asc_t (x - inflection_point\_asc_t))} + * \left(1.0-\frac{1.0}{ 1.0 + exp(-1.0 * slope\_desc_t (x - + * inflection_point\_desc_t))} \right)\f$ + * + * @param x The independent variable in the double logistic function (e.g., + * age or size in selectivity). + * @param pos Position index, e.g., which year. + */ + virtual const Type evaluate(const Type &x, size_t pos) + { + return fims_math::double_logistic( + inflection_point_asc.get_force_scalar(pos), slope_asc.get_force_scalar(pos), + inflection_point_desc.get_force_scalar(pos), slope_desc.get_force_scalar(pos), x); + } }; -} // namespace fims_popdy +} // namespace fims_popdy #endif /* POPULATION_DYNAMICS_SELECTIVITY_DOUBLE_LOGISTIC_HPP */ diff --git a/inst/include/population_dynamics/selectivity/functors/logistic.hpp b/inst/include/population_dynamics/selectivity/functors/logistic.hpp index 67aabb8f1..270905217 100644 --- a/inst/include/population_dynamics/selectivity/functors/logistic.hpp +++ b/inst/include/population_dynamics/selectivity/functors/logistic.hpp @@ -1,17 +1,17 @@ -/* - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. - * Refer to the LICENSE file for reuse information. - * - * The purpose of this file is to declare the LogisticSelectivity class - * which implements the logistic function from fims_math in the selectivity - * module. +/** + * @file logistic.hpp + * @brief Declares the LogisticSelectivity class which implements the logistic + * function from fims_math in the selectivity module. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef POPULATION_DYNAMICS_SELECTIVITY_LOGISTIC_HPP #define POPULATION_DYNAMICS_SELECTIVITY_LOGISTIC_HPP //#include "../../../interface/interface.hpp" #include "../../../common/fims_math.hpp" +#include "../../../common/fims_vector.hpp" #include "selectivity_base.hpp" namespace fims_popdy { @@ -22,29 +22,49 @@ namespace fims_popdy { */ template struct LogisticSelectivity : public SelectivityBase { - Type inflection_point; /**< 50% quantile of the value of the quantity of + fims::Vector inflection_point; /**< 50% quantile of the value of the quantity of interest (x); e.g. age at which 50% of the fish are selected */ - Type slope; /** slope; /**() {} - - virtual ~LogisticSelectivity() {} - - /** - * @brief Method of the logistic selectivity class that implements the - * logistic function from FIMS math. - * - * \f[ \frac{1.0}{ 1.0 + exp(-1.0 * slope (x - inflection_point))} \f] - * - * @param x The independent variable in the logistic function (e.g., age or - * size in selectivity). - */ - virtual const Type evaluate(const Type& x) { - return fims_math::logistic(inflection_point, slope, x); - } + LogisticSelectivity() : SelectivityBase() + { + } + + virtual ~LogisticSelectivity() + { + } + + /** + * @brief Method of the logistic selectivity class that implements the + * logistic function from FIMS math. + * + * \f[ \frac{1.0}{ 1.0 + exp(-1.0 * slope (x - inflection\_point))} \f] + * + * @param x The independent variable in the logistic function (e.g., age or + * size in selectivity). + */ + virtual const Type evaluate(const Type& x) + { + return fims_math::logistic(inflection_point[0], slope[0], x); + } + + /** + * @brief Method of the logistic selectivity class that implements the + * logistic function from FIMS math. + * + * \f[ \frac{1.0}{ 1.0 + exp(-1.0 * slope_t (x - {inflection\_point}_t))} \f] + * + * @param x The independent variable in the logistic function (e.g., age or + * size in selectivity). + * @param pos Position index, e.g., which year. + */ + virtual const Type evaluate(const Type& x, size_t pos) + { + return fims_math::logistic(inflection_point.get_force_scalar(pos), slope.get_force_scalar(pos), x); + } }; -} // namespace fims_popdy +} // namespace fims_popdy #endif /* POPULATION_DYNAMICS_SELECTIVITY_LOGISTIC_HPP */ diff --git a/inst/include/population_dynamics/selectivity/functors/selectivity_base.hpp b/inst/include/population_dynamics/selectivity/functors/selectivity_base.hpp index 2e589adb0..c49069815 100644 --- a/inst/include/population_dynamics/selectivity/functors/selectivity_base.hpp +++ b/inst/include/population_dynamics/selectivity/functors/selectivity_base.hpp @@ -1,15 +1,12 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * SelectivityBase file - * The purpose of this file is to declare the SelectivityBase class - * which is the base class for all selectivity functors. - * - * DEFINE guards for selectivity module outline to define the +/** + * @file selectivity_base.hpp + * @brief Declares the SelectivityBase class which is the base class for all + * selectivity functors. + * @details Defines guards for selectivity module outline to define the * selectivity hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef POPULATION_DYNAMICS_SELECTIVITY_BASE_HPP #define POPULATION_DYNAMICS_SELECTIVITY_BASE_HPP @@ -47,6 +44,14 @@ struct SelectivityBase : public fims_model_object::FIMSObject { * size in selectivity). */ virtual const Type evaluate(const Type& x) = 0; + + /** + * @brief Calculates the selectivity. + * @param x The independent variable in the logistic function (e.g., age or + * size in selectivity). + * @param pos Position index, e.g., which year. + */ + virtual const Type evaluate(const Type& x, size_t pos) = 0; }; // default id of the singleton selectivity class diff --git a/inst/include/population_dynamics/selectivity/selectivity.hpp b/inst/include/population_dynamics/selectivity/selectivity.hpp index e9d689b6e..f952ec62c 100644 --- a/inst/include/population_dynamics/selectivity/selectivity.hpp +++ b/inst/include/population_dynamics/selectivity/selectivity.hpp @@ -1,15 +1,12 @@ -/* - * - * This File is part of the NOAA, National Marine Fisheries Service - * Fisheries Integrated Modeling System project. See LICENSE in the - * source folder for reuse information. - * - * Selectivity module file - * The purpose of this file is to include any .hpp files within the - * subfolders so that only this file needs to included in the model.hpp file. - * - * DEFINE guards for selectivity module outline to define the +/** + * @file selectivity.hpp + * @brief Includes any .hpp files within the subfolders so that only this file + * needs to included in the model.hpp file. + * @details Defines guards for selectivity module outline to define the * selectivity hpp file if not already defined. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #ifndef FIMS_POPULATION_DYNAMICS_SELECTIVITY_HPP #define FIMS_POPULATION_DYNAMICS_SELECTIVITY_HPP diff --git a/inst/include/utilities/fims_json.hpp b/inst/include/utilities/fims_json.hpp index 8537cbabb..205aa104e 100644 --- a/inst/include/utilities/fims_json.hpp +++ b/inst/include/utilities/fims_json.hpp @@ -1,424 +1,536 @@ /** * @file fims_json.hpp - * @brief A simple JSON parsing and generation library. + * @brief A simple JSON parsing and generation library. * @details This library provides classes and functions for parsing JSON * strings and generating JSON data structures. + * @copyright This file is part of the NOAA, National Marine Fisheries Service + * Fisheries Integrated Modeling System project. See LICENSE in the source + * folder for reuse information. */ #include #include #include #include #include +#include #include -class JsonValue; -/** - * Alias for a JSON object, mapping strings to JSON values. - */ -using JsonObject = std::map; +namespace fims { + class JsonValue; + + /** + * Alias for a JSON object, mapping strings to JSON values. + */ + using JsonObject = std::map; + + /** + * Alias for a JSON array, containing a sequence of JSON values. + */ + using JsonArray = std::vector; + + /** + * Represents different types of JSON values. + */ + enum JsonValueType { + Null = 0, /**< Null JSON value. */ + Number, /**< Numeric JSON value. */ + String, /**< String JSON value. */ + Bool, /**< Boolean JSON value. */ + Object, /**< JSON object. */ + JArray /**< JSON array. */ + }; + + /** + * Represents a JSON value. + */ + class JsonValue { + public: + + /** Default constructor, initializes to Null value. */ + JsonValue() : type(JsonValueType::Null) { + } -/** - * Alias for a JSON array, containing a sequence of JSON values. - */ -using JsonArray = std::vector; + /** Constructor for numeric JSON value (i.e., integer). */ + JsonValue(int num) : type(JsonValueType::Number), number(num) { + } -/** - * Represents different types of JSON values. - */ -enum JsonValueType { - Null = 0, /**< Null JSON value. */ - Number, /**< Numeric JSON value. */ - String, /**< String JSON value. */ - Bool, /**< Boolean JSON value. */ - Object, /**< JSON object. */ - Array /**< JSON array. */ -}; + /** Constructor for numeric JSON value (i.e., double). */ + JsonValue(double num) : type(JsonValueType::Number), number(num) { + } -/** - * Represents a JSON value. - */ -class JsonValue { - public: - /** Default constructor, initializes to Null value. */ - JsonValue() : type(JsonValueType::Null) {} + /** Constructor for string JSON value. */ + JsonValue(const std::string& str) : type(JsonValueType::String), str(str) { + } - /** Constructor for numeric JSON value (i.e., integer). */ - JsonValue(int num) : type(JsonValueType::Number), number(num) {} + /** Constructor for boolean JSON value. */ + JsonValue(bool b) : type(JsonValueType::Bool), boolean(b) { + } - /** Constructor for numeric JSON value (i.e., double). */ - JsonValue(double num) : type(JsonValueType::Number), number(num) {} + /** Constructor for JSON object value. */ + JsonValue(const JsonObject& obj) : type(JsonValueType::Object), object(obj) { + } - /** Constructor for string JSON value. */ - JsonValue(const std::string& str) : type(JsonValueType::String), str(str) {} + /** Constructor for JSON array value. */ + JsonValue(const JsonArray& arr) : type(JsonValueType::JArray), array(arr) { + } - /** Constructor for boolean JSON value. */ - JsonValue(bool b) : type(JsonValueType::Bool), boolean(b) {} + /** Get the type of the JSON value. */ + JsonValueType GetType() const { + return type; + } - /** Constructor for JSON object value. */ - JsonValue(const JsonObject& obj) : type(JsonValueType::Object), object(obj) {} + /** Get the numeric value as an integer. */ + int GetInt() const { + return static_cast (number); + } - /** Constructor for JSON array value. */ - JsonValue(const JsonArray& arr) : type(JsonValueType::Array), array(arr) {} + /** Get the numeric value as a double. */ + double GetDouble() const { + return number; + } - /** Get the type of the JSON value. */ - JsonValueType GetType() const { return type; } + /** Get the string value. */ + const std::string& GetString() const { + return str; + } - /** Get the numeric value as an integer. */ - int GetInt() const { return static_cast(number); } + /** Get the boolean value. */ + bool GetBool() const { + return boolean; + } - /** Get the numeric value as a double. */ - double GetDouble() const { return number; } + /** Get the JSON object. */ + JsonObject& GetObject() { + return object; + } - /** Get the string value. */ - const std::string& GetString() const { return str; } + /** Get the JSON array. */ + JsonArray& GetArray() { + return array; + } - /** Get the boolean value. */ - bool GetBool() const { return boolean; } + private: + JsonValueType type; /**< Type of the JSON value. */ + double number; /**< Numeric value. */ + std::string str; /**< String value. */ + bool boolean; /**< Boolean value. */ + JsonObject object; /**< JSON object. */ + JsonArray array; /**< JSON array. */ + }; + + /** + * Parses JSON strings and generates JSON values. + */ + class JsonParser { + public: + /** Parse a JSON string and return the corresponding JSON value. */ + JsonValue Parse(const std::string& json); + /** Write a JSON value to a file. */ + void WriteToFile(const std::string& filename, JsonValue jsonValue); + /** Display a JSON value to the standard output. */ + void Show(JsonValue jsonValue); + + /** Remove whitespace in JSON. */ + static std::string removeWhitespace(const std::string& input) { + std::string result = input; + result.erase(std::remove_if(result.begin(), result.end(), ::isspace), result.end()); + return result; + } - /** Get the JSON object. */ - JsonObject& GetObject() { return object; } + /** + * @brief Formats a JSON string. + * @param json + * @return + */ + static std::string PrettyFormatJSON(const std::string& json) { + std::string result; + std::string input = JsonParser::removeWhitespace(json); + int indentLevel = 0; + bool inQuotes = false; + + for (size_t i = 0; i < input.size(); ++i) { + char current = input[i]; + + switch (current) { + case '{': + case '[': + result += current; + if (!inQuotes) { + result += '\n'; + indentLevel++; + result += std::string(indentLevel * 4, ' '); + } + break; + + case '}': + case ']': + if (!inQuotes) { + result += '\n'; + indentLevel--; + result += std::string(indentLevel * 4, ' '); + } + result += current; + break; + + case ',': + result += current; + if (!inQuotes) { + result += '\n'; + result += std::string(indentLevel * 4, ' '); + } + break; + + case ':': + result += current; + if (!inQuotes) result += " "; + break; + + case '"': + result += current; + // Toggle inQuotes when we encounter a double-quote + if (i == 0 || input[i - 1] != '\\') { + inQuotes = !inQuotes; + } + break; + + default: + result += current; + break; + } + } + return result; + } - /** Get the JSON array. */ - JsonArray& GetArray() { return array; } + private: + /** Skip whitespace characters in the input string. */ + void SkipWhitespace(); + /** Parse a JSON value. */ + JsonValue ParseValue(); + /** Parse a numeric JSON value. */ + JsonValue ParseNumber(); + /** Parse a string JSON value. */ + JsonValue ParseString(); + /** Parse a boolean JSON value. */ + JsonValue ParseBool(); + /** Parse a null JSON value. */ + JsonValue ParseNull(); + /** Parse a JSON object. */ + JsonValue ParseObject(); + /** Parse a JSON array. */ + JsonValue ParseArray(); + /** Write a JSON value to an output file stream. */ + void WriteJsonValue(std::ofstream& outputFile, JsonValue jsonValue); + /** Display a JSON value to an output stream. */ + void PrintJsonValue(std::ostream& outputFile, JsonValue jsonValue); + /** Indentation helper for printing JSON values in an output file stream. */ + void Indent(std::ostream& outputFile, int level); + /** Indentation helper for printing JSON values in an output stream. */ + void Indent(std::ofstream& outputFile, int level); + + std::string data; /**< Input JSON data. */ + size_t position; /**< Current position in the data. */ + }; + + /** + * Parse a JSON string and return the corresponding JSON value. + * @param json The JSON string to parse. + * @return The parsed JSON value. + */ + JsonValue JsonParser::Parse(const std::string& json) { + data = json; + position = 0; + return ParseValue(); + } - private: - JsonValueType type; /**< Type of the JSON value. */ - double number; /**< Numeric value. */ - std::string str; /**< String value. */ - bool boolean; /**< Boolean value. */ - JsonObject object; /**< JSON object. */ - JsonArray array; /**< JSON array. */ -}; + /** + * @brief Skip the white space. + * + */ + void JsonParser::SkipWhitespace() { + while (position < data.size() && std::isspace(data[position])) { + position++; + } + } -/** - * Parses JSON strings and generates JSON values. - */ -class JsonParser { - public: - /** Parse a JSON string and return the corresponding JSON value. */ - JsonValue Parse(const std::string& json); - /** Write a JSON value to a file. */ - void WriteToFile(const std::string& filename, JsonValue jsonValue); - /** Display a JSON value to the standard output. */ - void Show(JsonValue jsonValue); - - private: - /** Skip whitespace characters in the input string. */ - void SkipWhitespace(); - /** Parse a JSON value. */ - JsonValue ParseValue(); - /** Parse a numeric JSON value. */ - JsonValue ParseNumber(); - /** Parse a string JSON value. */ - JsonValue ParseString(); - /** Parse a boolean JSON value. */ - JsonValue ParseBool(); - /** Parse a null JSON value. */ - JsonValue ParseNull(); - /** Parse a JSON object. */ - JsonValue ParseObject(); - /** Parse a JSON array. */ - JsonValue ParseArray(); - /** Write a JSON value to an output file stream. */ - void WriteJsonValue(std::ofstream& outputFile, JsonValue jsonValue); - /** Display a JSON value to an output stream. */ - void PrintJsonValue(std::ostream& outputFile, JsonValue jsonValue); - /** Indentation helper for printing JSON values in an output file stream. */ - void Indent(std::ostream& outputFile, int level); - /** Indentation helper for printing JSON values in an output stream. */ - void Indent(std::ofstream& outputFile, int level); - - std::string data; /**< Input JSON data. */ - size_t position; /**< Current position in the data. */ -}; + /** + * Parse a JSON value. + * @return The parsed JSON value. + */ + JsonValue JsonParser::ParseValue() { + /** Skip whitespace characters in the input string. */ + SkipWhitespace(); + char current = data[position]; + if (current == '{') { + return ParseObject(); + } else if (current == '[') { + return ParseArray(); + } else if (current == '"') { + return ParseString(); + } else if (current == 't' || current == 'f') { + return ParseBool(); + } else if (current == 'n') { + return ParseNull(); + } else { + return ParseNumber(); + } + } -/** - * Parse a JSON string and return the corresponding JSON value. - * @param json The JSON string to parse. - * @return The parsed JSON value. - */ -JsonValue JsonParser::Parse(const std::string& json) { - data = json; - position = 0; - return ParseValue(); -} - -void JsonParser::SkipWhitespace() { - while (position < data.length() && std::isspace(data[position])) { - position++; - } -} + /** + * Parse a numeric JSON value. + * @return The parsed JSON value. + */ + JsonValue JsonParser::ParseNumber() { + size_t end_pos = position; + bool is_float = false; + while (end_pos < data.size() && + (std::isdigit(data[end_pos]) || data[end_pos] == '.' || + data[end_pos] == '-' || data[end_pos] == 'e' || + data[end_pos] == 'E')) { + if (data[end_pos] == '.' || data[end_pos] == 'e' || data[end_pos] == 'E') { + is_float = true; + } + end_pos++; + } -/** - * Parse a JSON value. - * @return The parsed JSON value. - */ -JsonValue JsonParser::ParseValue() { - /** Skip whitespace characters in the input string. */ - SkipWhitespace(); - char current = data[position]; - if (current == '{') { - return ParseObject(); - } else if (current == '[') { - return ParseArray(); - } else if (current == '"') { - return ParseString(); - } else if (current == 't' || current == 'f') { - return ParseBool(); - } else if (current == 'n') { - return ParseNull(); - } else { - return ParseNumber(); - } -} + std::string num_str = data.substr(position, end_pos - position); + position = end_pos; + + if (is_float) { + double num; + std::istringstream(num_str) >> num; + return JsonValue(num); + } else { + int num; + std::istringstream(num_str) >> num; + return JsonValue(num); + } + } -/** - * Parse a numeric JSON value. - * @return The parsed JSON value. - */ -JsonValue JsonParser::ParseNumber() { - size_t end_pos = position; - bool is_float = false; - while (end_pos < data.length() && - (std::isdigit(data[end_pos]) || data[end_pos] == '.' || - data[end_pos] == '-' || data[end_pos] == 'e' || - data[end_pos] == 'E')) { - if (data[end_pos] == '.' || data[end_pos] == 'e' || data[end_pos] == 'E') { - is_float = true; + /** + * Parse a string JSON value. + * @return The parsed JSON value. + */ + JsonValue JsonParser::ParseString() { + position++; // Skip the initial '"' + size_t end_pos = data.find('"', position); + std::string str = data.substr(position, end_pos - position); + position = end_pos + 1; + return JsonValue(str); } - end_pos++; - } - - std::string num_str = data.substr(position, end_pos - position); - position = end_pos; - - if (is_float) { - double num; - std::istringstream(num_str) >> num; - return JsonValue(num); - } else { - int num; - std::istringstream(num_str) >> num; - return JsonValue(num); - } -} -/** - * Parse a string JSON value. - * @return The parsed JSON value. - */ -JsonValue JsonParser::ParseString() { - position++; // Skip the initial '"' - size_t end_pos = data.find('"', position); - std::string str = data.substr(position, end_pos - position); - position = end_pos + 1; - return JsonValue(str); -} + /** + * Parse a boolean JSON value. + * @return The parsed JSON value. + */ + JsonValue JsonParser::ParseBool() { + if (data.compare(position, 4, "true") == 0) { + position += 4; + return JsonValue(true); + } else if (data.compare(position, 5, "false") == 0) { + position += 5; + return JsonValue(false); + } else { + // Invalid boolean value + return JsonValue(); + } + } -/** - * Parse a boolean JSON value. - * @return The parsed JSON value. - */ -JsonValue JsonParser::ParseBool() { - if (data.compare(position, 4, "true") == 0) { - position += 4; - return JsonValue(true); - } else if (data.compare(position, 5, "false") == 0) { - position += 5; - return JsonValue(false); - } else { - // Invalid boolean value - return JsonValue(); - } -} + /** + * Parse a null JSON value. + * @return The parsed JSON value. + */ + JsonValue JsonParser::ParseNull() { + if (data.compare(position, 4, "null") == 0) { + position += 4; + return JsonValue(); + } else { + // Invalid null value + return JsonValue(); + } + } -/** - * Parse a null JSON value. - * @return The parsed JSON value. - */ -JsonValue JsonParser::ParseNull() { - if (data.compare(position, 4, "null") == 0) { - position += 4; - return JsonValue(); - } else { - // Invalid null value - return JsonValue(); - } -} + /** + * Parse a JSON object. + * @return The parsed JSON value representing the object. + */ + JsonValue JsonParser::ParseObject() { + JsonObject obj; + position++; // Skip the initial '{' + + while (data[position] != '}') { + SkipWhitespace(); + std::string key = ParseString().GetString(); + + position++; // Skip the ':' + SkipWhitespace(); + JsonValue value = ParseValue(); + obj[key] = value; + + SkipWhitespace(); + if (data[position] == ',') { + position++; + } + } -/** - * Parse a JSON object. - * @return The parsed JSON value representing the object. - */ -JsonValue JsonParser::ParseObject() { - JsonObject obj; - position++; // Skip the initial '{' - - while (data[position] != '}') { - SkipWhitespace(); - std::string key = ParseString().GetString(); - - position++; // Skip the ':' - SkipWhitespace(); - JsonValue value = ParseValue(); - obj[key] = value; - - SkipWhitespace(); - if (data[position] == ',') { - position++; + position++; // Skip the trailing '}' + return JsonValue(obj); } - } - position++; // Skip the trailing '}' - return JsonValue(obj); -} + /** + * Parse a JSON array. + * @return The parsed JSON value representing the array. + */ + JsonValue JsonParser::ParseArray() { + JsonArray arr; + position++; // Skip the initial '[' + + while (data[position] != ']') { + SkipWhitespace(); + JsonValue value = ParseValue(); + arr.push_back(value); + + SkipWhitespace(); + if (data[position] == ',') { + position++; + } + } -/** - * Parse a JSON array. - * @return The parsed JSON value representing the array. - */ -JsonValue JsonParser::ParseArray() { - JsonArray arr; - position++; // Skip the initial '[' - - while (data[position] != ']') { - SkipWhitespace(); - JsonValue value = ParseValue(); - arr.push_back(value); - - SkipWhitespace(); - if (data[position] == ',') { - position++; + position++; // Skip the trailing ']' + return JsonValue(arr); } - } - position++; // Skip the trailing ']' - return JsonValue(arr); -} + /** + * Write a JSON value to an output file. + * @param filename The name of the output file. + * @param jsonValue The JSON value to write. + */ + void JsonParser::WriteToFile(const std::string& filename, JsonValue jsonValue) { + std::ofstream outputFile(filename); + if (!outputFile) { + std::cerr << "Error: Unable to open file " << filename << " for writing." + << std::endl; + return; + } -/** - * Write a JSON value to an output file. - * @param filename The name of the output file. - * @param jsonValue The JSON value to write. - */ -void JsonParser::WriteToFile(const std::string& filename, JsonValue jsonValue) { - std::ofstream outputFile(filename); - if (!outputFile) { - std::cerr << "Error: Unable to open file " << filename << " for writing." - << std::endl; - return; - } - - /** Call a private helper function to write JSON values recursively */ - WriteJsonValue(outputFile, jsonValue); -} + /** Call a private helper function to write JSON values recursively */ + WriteJsonValue(outputFile, jsonValue); + } -/** - * Write a JSON value to an output file. - * Private helper function to write JSON values recursively - * @param outputFile The output file stream. - * @param jsonValue The JSON value to write. - */ -void JsonParser::WriteJsonValue(std::ofstream& outputFile, - JsonValue jsonValue) { - switch (jsonValue.GetType()) { - case JsonValueType::Null: - outputFile << "null"; - break; - case JsonValueType::Number: - outputFile << jsonValue.GetDouble(); - break; - case JsonValueType::String: - outputFile << "\"" << jsonValue.GetString() << "\""; - break; - case JsonValueType::Bool: - outputFile << (jsonValue.GetBool() ? "true" : "false"); - break; - case JsonValueType::Object: { - JsonObject& obj = jsonValue.GetObject(); - outputFile << "{"; - bool first = true; - for (const auto& pair : obj) { - if (!first) { - outputFile << ","; - } - first = false; - outputFile << "\"" << pair.first << "\":"; - WriteJsonValue(outputFile, pair.second); - } - outputFile << "}"; - } break; - case JsonValueType::Array: { - JsonArray& arr = jsonValue.GetArray(); - outputFile << "["; - bool first = true; - for (const auto& value : arr) { - if (!first) { - outputFile << ","; + /** + * Write a JSON value to an output file. + * Private helper function to write JSON values recursively + * @param outputFile The output file stream. + * @param jsonValue The JSON value to write. + */ + void JsonParser::WriteJsonValue(std::ofstream& outputFile, + JsonValue jsonValue) { + switch (jsonValue.GetType()) { + case JsonValueType::Null: + outputFile << "null"; + break; + case JsonValueType::Number: + outputFile << jsonValue.GetDouble(); + break; + case JsonValueType::String: + outputFile << "\"" << jsonValue.GetString() << "\""; + break; + case JsonValueType::Bool: + outputFile << (jsonValue.GetBool() ? "true" : "false"); + break; + case JsonValueType::Object: + { + JsonObject& obj = jsonValue.GetObject(); + outputFile << "{"; + bool first = true; + for (const auto& pair : obj) { + if (!first) { + outputFile << ","; + } + first = false; + outputFile << "\"" << pair.first << "\":"; + WriteJsonValue(outputFile, pair.second); + } + outputFile << "}"; + } + break; + case JsonValueType::JArray: + { + JsonArray& arr = jsonValue.GetArray(); + outputFile << "["; + bool first = true; + for (const auto& value : arr) { + if (!first) { + outputFile << ","; + } + first = false; + WriteJsonValue(outputFile, value); + } + outputFile << "]"; + } + break; } - first = false; - WriteJsonValue(outputFile, value); - } - outputFile << "]"; - } break; - } -} + } -/** - * Display a JSON value to the standard output. - * @param jsonValue The JSON value to display. - */ -void JsonParser::Show(JsonValue jsonValue) { - this->PrintJsonValue(std::cout, jsonValue); - std::cout << std::endl; -} + /** + * Display a JSON value to the standard output. + * @param jsonValue The JSON value to display. + */ + void JsonParser::Show(JsonValue jsonValue) { + this->PrintJsonValue(std::cout, jsonValue); + std::cout << std::endl; + } -/** - * Display a JSON value to an output stream. - * @param output The output stream. - * @param jsonValue The JSON value to display. - */ -void JsonParser::PrintJsonValue(std::ostream& output, JsonValue jsonValue) { - switch (jsonValue.GetType()) { - case JsonValueType::Null: - output << "null"; - break; - case JsonValueType::Number: - output << jsonValue.GetDouble(); - break; - case JsonValueType::String: - output << "\"" << jsonValue.GetString() << "\""; - break; - case JsonValueType::Bool: - output << (jsonValue.GetBool() ? "true" : "false"); - break; - case JsonValueType::Object: { - JsonObject& obj = jsonValue.GetObject(); - output << "{"; - bool first = true; - for (const auto& pair : obj) { - if (!first) { - output << ","; + /** + * Display a JSON value to an output stream. + * @param output The output stream. + * @param jsonValue The JSON value to display. + */ + void JsonParser::PrintJsonValue(std::ostream& output, JsonValue jsonValue) { + switch (jsonValue.GetType()) { + case JsonValueType::Null: + output << "null"; + break; + case JsonValueType::Number: + output << jsonValue.GetDouble(); + break; + case JsonValueType::String: + output << "\"" << jsonValue.GetString() << "\""; + break; + case JsonValueType::Bool: + output << (jsonValue.GetBool() ? "true" : "false"); + break; + case JsonValueType::Object: + { + JsonObject& obj = jsonValue.GetObject(); + output << "{"; + bool first = true; + for (const auto& pair : obj) { + if (!first) { + output << ","; + } + first = false; + output << "\"" << pair.first << "\":"; + PrintJsonValue(output, pair.second); + } + output << "}"; + } + break; + case JsonValueType::JArray: + { + JsonArray& arr = jsonValue.GetArray(); + output << "["; + bool first = true; + for (const auto& value : arr) { + if (!first) { + output << ","; + } + first = false; + PrintJsonValue(output, value); + } + output << "]"; + } + break; } - first = false; - output << "\"" << pair.first << "\":"; - PrintJsonValue(output, pair.second); - } - output << "}"; - } break; - case JsonValueType::Array: { - JsonArray& arr = jsonValue.GetArray(); - output << "["; - bool first = true; - for (const auto& value : arr) { - if (!first) { - output << ","; - } - first = false; - PrintJsonValue(output, value); - } - output << "]"; - } break; - } -} + } +} \ No newline at end of file diff --git a/inst/templates/module_base_template.hpp b/inst/templates/module_base_template.hpp index ee83ca648..63568e58c 100644 --- a/inst/templates/module_base_template.hpp +++ b/inst/templates/module_base_template.hpp @@ -1,5 +1,5 @@ /* -* This File is part of the NOAA, National Marine Fisheries Service +* This file is part of the NOAA, National Marine Fisheries Service * Fisheries Integrated Modeling System project. See LICENSE in the * source folder for reuse information. * diff --git a/inst/templates/module_functor_template.hpp b/inst/templates/module_functor_template.hpp index 526e97600..28e7ebe3c 100644 --- a/inst/templates/module_functor_template.hpp +++ b/inst/templates/module_functor_template.hpp @@ -1,5 +1,5 @@ /* - * This File is part of the NOAA, National Marine Fisheries Service + * This file is part of the NOAA, National Marine Fisheries Service * Fisheries Integrated Modeling System project. * Refer to the LICENSE file for reuse information. * diff --git a/inst/templates/module_template.hpp b/inst/templates/module_template.hpp index 79c316b6e..c35dfe311 100644 --- a/inst/templates/module_template.hpp +++ b/inst/templates/module_template.hpp @@ -1,6 +1,6 @@ /* * - * This File is part of the NOAA, National Marine Fisheries Service + * This file is part of the NOAA, National Marine Fisheries Service * Fisheries Integrated Modeling System project. See LICENSE in the * source folder for reuse information. * diff --git a/man/FIMSFit.Rd b/man/FIMSFit.Rd new file mode 100644 index 000000000..e5e440daf --- /dev/null +++ b/man/FIMSFit.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsfit.R +\name{FIMSFit} +\alias{FIMSFit} +\title{Class constructors for class \code{FIMSFit} and associated child classes} +\usage{ +FIMSFit( + input, + obj, + opt = list(), + sdreport = list(), + timing = c(time_total = as.difftime(0, units = "secs")), + version = utils::packageVersion("FIMS") +) +} +\arguments{ +\item{input}{Input list as returned by \code{\link[=initialize_fims]{initialize_fims()}}.} + +\item{obj}{An object returned from \code{\link[TMB:MakeADFun]{TMB::MakeADFun()}}.} + +\item{opt}{An object returned from an optimizer, typically from +\code{\link[stats:nlminb]{stats::nlminb()}}, used to fit a TMB model.} + +\item{sdreport}{An object of the \code{sdreport} class as returned from +\code{\link[TMB:sdreport]{TMB::sdreport()}}.} + +\item{timing}{A vector of at least length one, where all entries are of the +\code{timediff} class and at least one is named "time_total". This information +is available in \code{\link[=fit_fims]{fit_fims()}} and added to this argument internally but if +you are a power user you can calculate the time it took to run your model +by subtracting two \code{\link[=Sys.time]{Sys.time()}} objects.} + +\item{version}{The version of FIMS that was used to optimize the model. If +\code{\link[=fit_fims]{fit_fims()}} was not used to optimize the model, then the default is to +use the current version of the package that is loaded.} +} +\value{ +An object with an S4 class of \code{FIMSFit} is returned. The object will have the +following slots: +\describe{ +\item{\code{input}:}{ +A list containing the model setup in the same form it was passed. +} +\item{\code{obj}:}{ +A list returned from \code{\link[TMB:MakeADFun]{TMB::MakeADFun()}} in the same form it was passed. +} +\item{\code{opt}:}{ +A list containing the optimized model in the same form it was passed. +} +\item{\code{max_gradient}:}{ +The maximum gradient found when optimizing the model. The default is +\code{NA}, which means that the model was not optimized. +} +\item{\code{report}:}{ +A list containing the model report from \code{obj[["report"]]()}. +} +\item{\code{sdreport}:}{ +A object with the \code{sdreport} class containing the output from +\code{TMB::sdreport(obj)}. +} +\item{\code{estimates}:}{ +A table of parameter values and their uncertainty. +} +\item{\code{timing}:}{ +The length of time it took to run the model if it was optimized. +} +\item{\code{version}:}{ +The package version of FIMS used to fit the model or at least the +version used to create this output, which will not always be the same +if you are running this function yourself. +} +} +} +\description{ +Create an object with the class of \code{FIMSFit} after running a FIMS model. This +is typically done within \code{\link[=fit_fims]{fit_fims()}} but it can be create manually by the +user if they have used their own bespoke code to fit a FIMS model. +} +\keyword{fit_fims} diff --git a/man/FIMSFrame.Rd b/man/FIMSFrame.Rd index 969f21ecd..66bfe691f 100644 --- a/man/FIMSFrame.Rd +++ b/man/FIMSFrame.Rd @@ -8,17 +8,59 @@ FIMSFrame(data) } \arguments{ \item{data}{A \code{data.frame} that contains the necessary columns to construct -a data frame of a given \code{FIMSFrame-class}.} +a \code{FIMSFrame-class} object. Currently, those columns are +type, name, age, length, datestart, dateend, value, unit, and uncertainty. See +the data1 object in FIMS, e.g., \code{data(data1, package = "FIMS")}.} } \value{ -An object of the S4 class \code{FIMSFrame} or one of its child classes is +An object of the S4 class \code{FIMSFrame} class, or one of its child classes, is validated and then returned. All objects will at a minimum have a slot called \code{data} to store the input data frame. Additional slots are dependent -on the child class. Use \code{\link[=showClass]{showClass()}} to see all available slots. +on the child class. Use \code{\link[methods:RClassUtils]{methods::showClass()}} to see all available slots. } \description{ -All constructor functions take a single input and build an object specific to -the needs of each model type within \pkg{FIMS}. \code{FIMSFrame} is the -parent class and the associated child classes have additional slots needed -for each model type. +All constructor functions take a single input and build an object specific +to the needs of each model type within \pkg{FIMS}. \code{FIMSFrame} is the parent +class. Future, associated child classes will have the additional slots +needed for different types of models. } +\details{ +\subsection{data}{ + +The input data are both sorted and expanded before returning them in the +data slot. +\subsection{Sorting}{ + +It is important that the order of the rows in the data are correct but it is +not expected that the user will do this. Instead, the returned data are +sorted using \code{\link[dplyr:arrange]{dplyr::arrange()}} before placing them in the data slot. Data +are first sorted by data type, placing all weight-at-age data next to other +weight-at-age data and all landings data next to landings data. Thus, +age-composition data will come first because their type is "age" and "a" is +first in the alphabet. All other types will follow according to their order +in the alphabet. +Next, within each type, data are organized by fleet. So, age-composition +information for fleet1 will come before survey1. Next, all data within type +and fleet are arranged by datestart, e.g., by year. That is the end of the +sorting for time series data like landings and indices. +The biological data are further sorted by bin. Thus, age-composition +information will be arranged as follows:\tabular{lcccr}{ + type \tab name \tab datestart \tab age \tab value \cr + age \tab fleet1 \tab 2022-01-01 \tab 1 \tab 0.3 \cr + age \tab fleet1 \tab 2022-01-01 \tab 2 \tab 0.7 \cr + age \tab fleet1 \tab 2023-01-01 \tab 1 \tab 0.5 \cr +} + + +Length composition-data are sorted the same way but by length bin instead of +by age bin. It becomes more complicated for the age-to-length-conversion +data, which are sorted by type, name, datestart, age, and then length. So, a +full set of length, e.g., length 10, length 20, length 30, etc., is placed +together for a given age. After that age, another entire set of length +information will be provided for that next age. Once the year is complete +for a given fleet then the next year will begin. +} + +} +} +\keyword{FIMSFrame} diff --git a/man/Rcpp_Math.Rd b/man/Rcpp_Math.Rd new file mode 100644 index 000000000..bd5539645 --- /dev/null +++ b/man/Rcpp_Math.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/zzz.R +\name{Ops,Rcpp_Parameter,Rcpp_Parameter-method} +\alias{Ops,Rcpp_Parameter,Rcpp_Parameter-method} +\alias{Ops,Rcpp_Parameter,numeric-method} +\alias{Ops,numeric,Rcpp_Parameter-method} +\alias{Ops,Rcpp_ParameterVector,Rcpp_ParameterVector-method} +\alias{Ops,Rcpp_ParameterVector,numeric-method} +\alias{Ops,numeric,Rcpp_ParameterVector-method} +\alias{Math,Rcpp_ParameterVector-method} +\title{Sets methods for operators under the S4 Generic Group, Ops} +\usage{ +\S4method{Ops}{Rcpp_Parameter,Rcpp_Parameter}(e1, e2) + +\S4method{Ops}{Rcpp_Parameter,numeric}(e1, e2) + +\S4method{Ops}{numeric,Rcpp_Parameter}(e1, e2) + +\S4method{Ops}{Rcpp_ParameterVector,Rcpp_ParameterVector}(e1, e2) + +\S4method{Ops}{Rcpp_ParameterVector,numeric}(e1, e2) + +\S4method{Ops}{numeric,Rcpp_ParameterVector}(e1, e2) + +\S4method{Math}{Rcpp_ParameterVector}(x) +} +\arguments{ +\item{e1, e2}{An Rcpp_Parameter or Rcpp_ParameterVector class object or a +numeric vector or value.} + +\item{x}{An Rcpp_ParameterVector class object.} +} +\value{ +A numeric or logical value(s) depending on the generic and the length of +the input values. + +A vector of numeric values. +} +\description{ +Ops include Arith (\code{+}, \code{-}, \code{*}, \code{^}, \code{\%\%}, \code{\%/\%}, and \code{/}); +Compare (\code{==}, \code{>}, \code{<}, \code{!=}, \code{<=}, and \code{>=}); and +Logic (\code{&}, \code{|}). + +Methods of mathematical functions include trigonometry functions, \code{abs}, +\code{sign}, \code{sqrt}, \code{ceiling}, \code{floor}, \code{trunc}, \code{cummax}, \code{cumprod}, \code{cumsum}, +\code{log}, \code{log10}, \code{log2}, \code{log1p}, \code{exp}, \code{expm1}, \code{gamma}, \code{lgamma}, +\code{digamma}, and \code{trigamma}. +} +\keyword{set_methods} diff --git a/man/Rcpp_ParameterVector.Rd b/man/Rcpp_ParameterVector.Rd new file mode 100644 index 000000000..a0b70da60 --- /dev/null +++ b/man/Rcpp_ParameterVector.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/zzz.R +\name{[<-,Rcpp_ParameterVector,ANY,ANY,ANY-method} +\alias{[<-,Rcpp_ParameterVector,ANY,ANY,ANY-method} +\alias{[,Rcpp_ParameterVector,numeric,ANY,ANY-method} +\alias{length,Rcpp_ParameterVector-method} +\alias{sum,Rcpp_ParameterVector-method} +\alias{dim,Rcpp_ParameterVector-method} +\alias{Summary,Rcpp_ParameterVector-method} +\title{Setter for \code{Rcpp_ParameterVector}} +\usage{ +\S4method{[}{Rcpp_ParameterVector,ANY,ANY,ANY}(x, i, j) <- value + +\S4method{[}{Rcpp_ParameterVector,numeric,ANY,ANY}(x, i) + +\S4method{length}{Rcpp_ParameterVector}(x) + +\S4method{sum}{Rcpp_ParameterVector}(x) + +\S4method{dim}{Rcpp_ParameterVector}(x) + +\S4method{Summary}{Rcpp_ParameterVector}(x) +} +\arguments{ +\item{x}{An Rcpp_ParameterVector class object.} + +\item{i}{An integer specifying the location in R speak, where indexing +starts at one, of the vector that you wish to get information from.} + +\item{j}{Not used with \code{Rcpp_ParameterVector} because it is a vector.} + +\item{value}{The value you want to set the indexed location to.} +} +\value{ +For \verb{[<-}, the index \code{i} of object \code{x} is set to \code{value}. + +For \code{[}, the index \code{i} of object \code{x} is returned. + +For \code{length()}, the length of object \code{x} is returned as an integer. + +For \code{sum()}, the sum of object \code{x} is returned as a numeric value. + +For \code{dim()}, the dimensions of object \code{x} is returned as a single integer +because there is only one dimension to return for a vector. + +\code{Summary} returns a single or two numeric or logical values. +} +\description{ +In R, indexing starts at one. But, in C++ indexing starts at zero. These +functions do the translation for you so you can think in R terms. + +In R, indexing starts at one. But, in C++ indexing starts at zero. This +function does the translation for you so you can think in R terms. + +Methods of summary functions include \code{max}, \code{min}, \code{range}, \code{prod}, \code{sum}, +\code{any}, and \code{all}. +} +\keyword{set_methods} diff --git a/man/create_default_parameters.Rd b/man/create_default_parameters.Rd new file mode 100644 index 000000000..4d3d31adc --- /dev/null +++ b/man/create_default_parameters.Rd @@ -0,0 +1,113 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/create_default_parameters.R +\name{create_default_parameters} +\alias{create_default_parameters} +\alias{update_parameters} +\title{Create default parameters for a FIMS model} +\usage{ +create_default_parameters( + data, + fleets, + recruitment = list(form = "BevertonHoltRecruitment", process_distribution = c(log_devs + = "DnormDistribution")), + growth = list(form = "EWAAgrowth"), + maturity = list(form = "LogisticMaturity") +) + +update_parameters(current_parameters, modified_parameters) +} +\arguments{ +\item{data}{An S4 object. FIMS input data.} + +\item{fleets}{A named list of settings for the fleet module. Each element of +the list should specify a fleet's selectivity form and settings for the +data distribution. If this argument is missing, default values will be +applied for each fleet that is not specified but present in \code{data} based +on the types of information present for that fleet.} + +\item{recruitment}{A list specifying the settings for the recruitment +module. The default is a Beverton--Holt recruitment relationship with +log-normal recruitment deviations.} + +\item{growth}{A list specifying the settings for the growth module. The +default is \code{"EWAAgrowth"}.} + +\item{maturity}{A list specifying the settings for the maturity module. The +default is \code{"LogisticMaturity"}.} + +\item{current_parameters}{A list containing the current input parameters, including: +\describe{ +\item{\code{parameters}:}{A list of parameter inputs.} +\item{\code{modules}:}{A list of module names used in the model.} +}} + +\item{modified_parameters}{A named list representing new parameter values to update.} +} +\value{ +A list containing the following two entries: +\describe{ +\item{\code{parameters}:}{A list of parameter inputs for the FIMS +model.} +\item{\code{modules}:}{A list of modules with default or user-provided +settings.} +} + +A list containing: +\describe{ +\item{parameters}{A list of updated parameter inputs that +includes any modifications made by the user.} +\item{modules}{The unchanged list of module names from the current +input.} +} +} +\description{ +This function generates default parameter settings for a Fisheries +Integrated Modeling System (FIMS) model, including recruitment, growth, +maturity, population, and fleet configurations. It applies default +configurations when specific module settings are not provided by the user. + +This function updates the input parameters of a Fisheries Integrated +Modeling System (FIMS) model. It allows users to modify specific parameters +by providing new values, while retaining the existing modules information +from the current input. +} +\examples{ +\dontrun{ +data("data1") +fims_frame <- FIMSFrame(data1) +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution" + ) +) +fleet2 <- list( + selectivity = list(form = "DoubleLogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) +) +default_parameters <- fims_frame |> + create_default_parameters( + fleets = list(fleet1 = fleet1, fleet2 = fleet2, survey1 = survey1), + recruitment = list( + form = "BevertonHoltRecruitment", + process_distribution = c(log_devs = "DnormDistribution") + ), + growth = list(form = "EWAAgrowth"), + maturity = list(form = "LogisticMaturity") + ) +} +} +\seealso{ +\itemize{ +\item \code{\link[=update_parameters]{update_parameters()}} +} + +\itemize{ +\item \code{\link[=create_default_parameters]{create_default_parameters()}} +} +} diff --git a/man/data_mile1.Rd b/man/data1.Rd similarity index 72% rename from man/data_mile1.Rd rename to man/data1.Rd index fd5fe1406..8a12d4827 100644 --- a/man/data_mile1.Rd +++ b/man/data1.Rd @@ -1,19 +1,21 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_mile1.R +% Please edit documentation in R/data1.R \docType{data} -\name{data_mile1} -\alias{data_mile1} -\title{FIMS input data frame for milestone 1} +\name{data1} +\alias{data1} +\title{FIMS input data frame} \format{ -A data frame with 1140 observations of -8 variables: -\describe{ -\item{type}{The type of data the row contains. Allowed types include -\code{age}, \code{index}, \code{landings}, and \code{weight-at-age} data.} +A data frame with 19080 observations of 9 +variables: +\describe{ \item{type}{The type of data the row contains. Allowed types +include \code{age}, \code{length}, \code{index}, \code{landings}, \code{age-to-length-conversion}, +and \code{weight-at-age} data.} \item{name}{A character string providing the name of the information source -that the data was collected from, e.g., \code{"Trawl fishery"}} +that the data was collected from, e.g., \code{"Trawl fishery"}.} \item{age}{An integer age. Entry can be \code{NA} if information pertains to multiple ages, e.g., total catch rather than catch of age-4 fish.} +\item{length}{A numeric length. Entry can be \code{NA} if information doesn't +pertain to length.} \item{datestart,dateend}{Start and end dates of the data collection period. Format all dates using \code{yyyy-mm-dd}, which can accommodate fake years such as \code{0001-01-01}.} @@ -35,11 +37,11 @@ be your input sample size. \url{www.github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison} } \usage{ -data_mile1 +data1 } \description{ A dataset containing information necessary to run an age-structured stock -assessment model in FIMS for milestone 1. This data was generated using +assessment model in FIMS. This data was generated using the \code{ASSAMC} package written for the \href{www.github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison}{model comparison project}. } \keyword{datasets} diff --git a/man/fit_fims.Rd b/man/fit_fims.Rd new file mode 100644 index 000000000..1e7fdfb2b --- /dev/null +++ b/man/fit_fims.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsfit.R +\name{fit_fims} +\alias{fit_fims} +\title{Fit a FIMS model (BETA)} +\usage{ +fit_fims( + input, + get_sd = TRUE, + save_sd = TRUE, + number_of_loops = 3, + optimize = TRUE, + number_of_newton_steps = 0, + control = list(eval.max = 10000, iter.max = 10000, trace = 0), + filename = NULL +) +} +\arguments{ +\item{input}{Input list as returned by \code{\link[=initialize_fims]{initialize_fims()}}.} + +\item{get_sd}{A boolean specifying if the \code{\link[TMB:sdreport]{TMB::sdreport()}} should be +calculated?} + +\item{save_sd}{A logical, with the default \code{TRUE}, indicating whether the +sdreport is returned in the output. If \code{FALSE}, the slot for the report +will be empty.} + +\item{number_of_loops}{A positive integer specifying the number of +iterations of the optimizer that will be performed to improve the +gradient. The default is three, leading to four total optimization steps.} + +\item{optimize}{Optimize (TRUE, default) or (FALSE) build and return +a list containing the obj and report slot.} + +\item{number_of_newton_steps}{The number of Newton steps using the inverse +Hessian to do after optimization. Not yet implemented.} + +\item{control}{A list of optimizer settings passed to \code{\link[stats:nlminb]{stats::nlminb()}}. The +the default is a list of length three with \code{eval.max = 1000}, +\code{iter.max = 10000}, and \code{trace = 0}.} + +\item{filename}{Character string giving a file name to save the fitted +object as an RDS object. Defaults to 'fit.RDS', and a value of NULL +indicates not to save it. If specified, it must end in .RDS. The file is +written to folder given by \code{input[["path"]]}. Not yet implemented.} +} +\value{ +An object of class \code{FIMSFit} is returned, 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}. +} +\description{ +Fit a FIMS model (BETA) +} +\details{ +This function is a beta version still and subject to change +without warning. +} +\seealso{ +\itemize{ +\item \code{\link[=FIMSFit]{FIMSFit()}} +} +} +\keyword{fit_fims} diff --git a/man/get_FIMSFit.Rd b/man/get_FIMSFit.Rd new file mode 100644 index 000000000..5404d8dd1 --- /dev/null +++ b/man/get_FIMSFit.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsfit.R +\name{get_FIMSFit} +\alias{get_FIMSFit} +\alias{get_input} +\alias{get_input,FIMSFit-method} +\alias{get_report} +\alias{get_report,FIMSFit-method} +\alias{get_obj} +\alias{get_obj,FIMSFit-method} +\alias{get_opt} +\alias{get_opt,FIMSFit-method} +\alias{get_max_gradient} +\alias{get_max_gradient,FIMSFit-method} +\alias{get_sdreport} +\alias{get_sdreport,FIMSFit-method} +\alias{get_estimates} +\alias{get_estimates,FIMSFit-method} +\alias{get_number_of_parameters} +\alias{get_number_of_parameters,FIMSFit-method} +\alias{get_timing} +\alias{get_timing,FIMSFit-method} +\alias{get_version} +\alias{get_version,FIMSFit-method} +\title{Get a slot in a FIMSFit object} +\usage{ +get_input(x) + +\S4method{get_input}{FIMSFit}(x) + +get_report(x) + +\S4method{get_report}{FIMSFit}(x) + +get_obj(x) + +\S4method{get_obj}{FIMSFit}(x) + +get_opt(x) + +\S4method{get_opt}{FIMSFit}(x) + +get_max_gradient(x) + +\S4method{get_max_gradient}{FIMSFit}(x) + +get_sdreport(x) + +\S4method{get_sdreport}{FIMSFit}(x) + +get_estimates(x) + +\S4method{get_estimates}{FIMSFit}(x) + +get_number_of_parameters(x) + +\S4method{get_number_of_parameters}{FIMSFit}(x) + +get_timing(x) + +\S4method{get_timing}{FIMSFit}(x) + +get_version(x) + +\S4method{get_version}{FIMSFit}(x) +} +\arguments{ +\item{x}{Output returned from \code{\link[=fit_fims]{fit_fims()}}.} +} +\value{ +\code{\link[=get_input]{get_input()}} returns the list that was used to fit the FIMS model, which +is the returned object from \code{\link[=create_default_parameters]{create_default_parameters()}}. + +\code{\link[=get_report]{get_report()}} returns the TMB report, where anything that is flagged as +reportable in the C++ code is returned. + +\code{\link[=get_obj]{get_obj()}} returns the output from \code{\link[TMB:MakeADFun]{TMB::MakeADFun()}}. + +\code{\link[=get_opt]{get_opt()}} returns the output from \code{\link[=nlminb]{nlminb()}}, which is the minimizer used +in \code{\link[=fit_fims]{fit_fims()}}. + +\code{\link[=get_max_gradient]{get_max_gradient()}} returns the maximum gradient found when optimizing the +model. + +\code{\link[=get_sdreport]{get_sdreport()}} returns the list from \code{\link[TMB:sdreport]{TMB::sdreport()}}. + +\code{\link[=get_estimates]{get_estimates()}} returns a tibble of parameter values and their +uncertainties from a fitted model. + +\code{\link[=get_number_of_parameters]{get_number_of_parameters()}} returns a vector of integers specifying the +number of fixed-effect parameters and the number of random-effect parameters +in the model. + +\code{\link[=get_timing]{get_timing()}} returns the amount of time it took to run the model in +seconds as a \code{difftime} object. + +\code{\link[=get_version]{get_version()}} returns the \code{package_version} of FIMS that was used to fit +the model. +} +\description{ +There is an accessor function for each slot in the S4 class \code{FIMSFit}, where +the function is named \verb{get_*()} and the star can be replaced with the slot +name, e.g., \code{\link[=get_input]{get_input()}}. These accessor functions are the preferred way +to access objects stored in the available slots. +} +\seealso{ +\itemize{ +\item \code{\link[=fit_fims]{fit_fims()}} +\item \code{\link[=create_default_parameters]{create_default_parameters()}} +} +} +\keyword{fit_fims} diff --git a/man/get_FIMSFrame.Rd b/man/get_FIMSFrame.Rd new file mode 100644 index 000000000..8a2c3f0fe --- /dev/null +++ b/man/get_FIMSFrame.Rd @@ -0,0 +1,126 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsframe.R +\name{get_FIMSFrame} +\alias{get_FIMSFrame} +\alias{get_data} +\alias{get_data,FIMSFrame-method} +\alias{get_data,data.frame-method} +\alias{get_fleets} +\alias{get_fleets,FIMSFrame-method} +\alias{get_fleets,data.frame-method} +\alias{get_n_years} +\alias{get_n_years,FIMSFrame-method} +\alias{get_n_years,data.frame-method} +\alias{get_start_year} +\alias{get_start_year,FIMSFrame-method} +\alias{get_start_year,data.frame-method} +\alias{get_end_year} +\alias{get_end_year,FIMSFrame-method} +\alias{get_end_year,data.frame-method} +\alias{get_ages} +\alias{get_ages,FIMSFrame-method} +\alias{get_ages,data.frame-method} +\alias{get_n_ages} +\alias{get_n_ages,FIMSFrame-method} +\alias{get_n_ages,data.frame-method} +\alias{get_lengths} +\alias{get_lengths,FIMSFrame-method} +\alias{get_lengths,data.frame-method} +\alias{get_n_lengths} +\alias{get_n_lengths,FIMSFrame-method} +\alias{get_n_lengths,data.frame-method} +\title{Get a slot in a FIMSFrame object} +\usage{ +get_data(x) + +\S4method{get_data}{FIMSFrame}(x) + +\S4method{get_data}{data.frame}(x) + +get_fleets(x) + +\S4method{get_fleets}{FIMSFrame}(x) + +\S4method{get_fleets}{data.frame}(x) + +get_n_years(x) + +\S4method{get_n_years}{FIMSFrame}(x) + +\S4method{get_n_years}{data.frame}(x) + +get_start_year(x) + +\S4method{get_start_year}{FIMSFrame}(x) + +\S4method{get_start_year}{data.frame}(x) + +get_end_year(x) + +\S4method{get_end_year}{FIMSFrame}(x) + +\S4method{get_end_year}{data.frame}(x) + +get_ages(x) + +\S4method{get_ages}{FIMSFrame}(x) + +\S4method{get_ages}{data.frame}(x) + +get_n_ages(x) + +\S4method{get_n_ages}{FIMSFrame}(x) + +\S4method{get_n_ages}{data.frame}(x) + +get_lengths(x) + +\S4method{get_lengths}{FIMSFrame}(x) + +\S4method{get_lengths}{data.frame}(x) + +get_n_lengths(x) + +\S4method{get_n_lengths}{FIMSFrame}(x) + +\S4method{get_n_lengths}{data.frame}(x) +} +\arguments{ +\item{x}{An object returned from \code{\link[=FIMSFrame]{FIMSFrame()}}.} +} +\value{ +\code{\link[=get_data]{get_data()}} returns a data frame of the class \code{tbl_df} containing data for +a FIMS model in a long format. The tibble will potentially have the +following columns depending if it fits to ages and lengths or just one of +them: +type, name, age, length, datestart, dateend, value, unit, and uncertainty. + +\code{\link[=get_fleets]{get_fleets()}} returns a vector of integer values specifying which fleets in +the model are fishing fleets. + +\code{\link[=get_n_years]{get_n_years()}} returns an integer specifying the number of years in the +model. + +\code{\link[=get_start_year]{get_start_year()}} returns an integer specifying the start year of the +model. + +\code{\link[=get_end_year]{get_end_year()}} returns an integer specifying the end year of the +model. + +\code{\link[=get_ages]{get_ages()}} returns a vector of age bins used in the model. + +\code{\link[=get_n_ages]{get_n_ages()}} returns an integer specifying the number of age bins used in +the model. + +\code{\link[=get_lengths]{get_lengths()}} returns a vector of length bins used in the model. + +\code{\link[=get_n_lengths]{get_n_lengths()}} returns an integer specifying the number of length bins +used in the model. +} +\description{ +There is an accessor function for each slot in the S4 class \code{FIMSFrame}, +where the function is named \verb{get_*()} and the star can be replaced with the +slot name, e.g., \code{\link[=get_data]{get_data()}}. These accessor functions are the preferred +way to access objects stored in the available slots. +} +\keyword{FIMSFrame} diff --git a/man/initialize_data_distribution.Rd b/man/initialize_data_distribution.Rd new file mode 100644 index 000000000..cb8fd5816 --- /dev/null +++ b/man/initialize_data_distribution.Rd @@ -0,0 +1,98 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distribution_formulas.R +\name{initialize_data_distribution} +\alias{initialize_data_distribution} +\alias{initialize_process_distribution} +\title{Set up a new distribution for a data type or a process} +\usage{ +initialize_data_distribution( + module, + family, + sd = list(value = 1, estimated = FALSE), + data_type = c("index", "agecomp", "lengthcomp") +) + +initialize_process_distribution( + module, + par, + family, + sd = list(value = 1, estimated = FALSE), + is_random_effect = FALSE +) +} +\arguments{ +\item{module}{An identifier to a C++ fleet module that is linked to the data +of interest.} + +\item{family}{A description of the error distribution and link function to +be used in the model. The argument takes a family class, e.g., +\code{stats::gaussian(link = "identity")}.} + +\item{sd}{A list of length two. The first entry is named \code{"value"} and it +stores the initial values (scalar or vector) for the relevant standard +deviations. The default is \code{value = 1}. The second entry is named +\code{"estimated"} and it stores a vector of booleans (default = FALSE) is a +scalar indicating whether or not standard deviation is estimated. If +\code{"value"} is a vector and \code{"estimated"} is a scalar, the single value +specified \code{"estimated"} value will be repeated to match the length of +\code{value}. Otherwise, the dimensions of the two must match.} + +\item{data_type}{A string specifying the type of data that the +distribution will be fit to. Allowable types include +c, index, agecomp, lengthcomp +and the default is +c.} + +\item{par}{A string specifying the parameter name the distribution applies +to. Parameters must be members of the specified module. Use +\code{methods::show(module)} to obtain names of parameters within the module.} + +\item{is_random_effect}{A boolean indicating whether or not the process is +estimated as a random effect.} +} +\value{ +A reference class. is returned. Use \code{\link[methods:show]{methods::show()}} to view the various +Rcpp class fields, methods, and documentation. +} +\description{ +Use \code{\link[methods:new]{methods::new()}} to set up a distribution within an existing module with +the necessary linkages between the two. For example, a fleet module will need +a distributional assumption for parts of the data associated with it, which +requires the use of \code{initialize_data_distribution()}, and a recruitment +module, like the Beverton--Holt stock--recruit relationship, will need a +distribution associated with the recruitment deviations, which requires +\code{initialize_process_distribution()}. +} +\examples{ +\dontrun{ +# Set up a new data distribution +n_years <- 30 +# Create a new fleet module +fleet <- methods::new(Fleet) +# Create a distribution for the fleet module +fleet_distribution <- initialize_data_distribution( + module = fishing_fleet, + family = lognormal(link = "log"), + sd = list( + value = rep(sqrt(log(0.01^2 + 1)), n_years), + estimated = rep(FALSE, n_years) # Could also be a single FALSE + ), + data_type = "index" +) + +# Set up a new process distribution +# Create a new recruitment module +recruitment <- methods::new(BevertonHoltRecruitment) +# view parameter names of the recruitment module +methods::show(BevertonHoltRecruitment) +# Create a distribution for the recruitment module +recruitment_distribution <- initialize_process_distribution( + module = recruitment, + par = "log_devs", + family = gaussian(), + sd = list(value = 0.4, estimated = FALSE), + is_random_effect = FALSE +) +} +} +\keyword{distribution} diff --git a/man/initialize_fims.Rd b/man/initialize_fims.Rd new file mode 100644 index 000000000..03366716a --- /dev/null +++ b/man/initialize_fims.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/initialize_modules.R +\name{initialize_fims} +\alias{initialize_fims} +\title{Initialize FIMS modules} +\usage{ +initialize_fims(parameters, data) +} +\arguments{ +\item{parameters}{A list. Contains parameters and modules required for +initialization.} + +\item{data}{An S4 object. FIMS input data.} +} +\value{ +A list containing parameters for the initialized FIMS modules, ready for use +in TMB modeling. +} +\description{ +Initializes multiple modules within the Fisheries Integrated Modeling System +(FIMS), including fleet, recruitment, growth, maturity, and population +modules. This function iterates over the provided fleets, setting up +necessary sub-modules such as selectivity, index, and age composition. It +also sets up distribution models for fishery index and age-composition data. +} diff --git a/man/is.FIMSFit.Rd b/man/is.FIMSFit.Rd new file mode 100644 index 000000000..33ae69fc4 --- /dev/null +++ b/man/is.FIMSFit.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsfit.R +\name{is.FIMSFit} +\alias{is.FIMSFit} +\title{Check if an object is of class FIMSFit} +\usage{ +is.FIMSFit(x) +} +\arguments{ +\item{x}{Returned list from \code{\link[=fit_fims]{fit_fims()}}.} +} +\description{ +Check if an object is of class FIMSFit +} +\keyword{fit_fims} diff --git a/man/is.FIMSFits.Rd b/man/is.FIMSFits.Rd new file mode 100644 index 000000000..217507a01 --- /dev/null +++ b/man/is.FIMSFits.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsfit.R +\name{is.FIMSFits} +\alias{is.FIMSFits} +\title{Check if an object is a list of FIMSFit objects} +\usage{ +is.FIMSFits(x) +} +\arguments{ +\item{x}{List of fits returned from multiple calls to \code{\link[=fit_fims]{fit_fims()}}.} +} +\description{ +Check if an object is a list of FIMSFit objects +} +\keyword{fit_fims} diff --git a/man/is_fims_verbose.Rd b/man/is_fims_verbose.Rd new file mode 100644 index 000000000..98c4c7a18 --- /dev/null +++ b/man/is_fims_verbose.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/is_fims_verbose.R +\name{is_fims_verbose} +\alias{is_fims_verbose} +\title{Should FIMS be verbose?} +\usage{ +is_fims_verbose() +} +\value{ +A logical is returned where \code{TRUE} ensures messages from \code{cli::cli_inform()} +are printed to the console. +} +\description{ +Verbosity is set globally for FIMS using +\code{options(rlib_message_verbosity = "quiet")} to stop the printing of messages +from \code{cli::cli_inform()}. Using a global option allows for verbose to not +have to be an argument to every function. All \code{cli::cli_abort()} messages are +printed to the console no matter what the global option is set to. +} +\examples{ +# function is not exported +\dontrun{ +FIMS:::is_fims_verbose() +} +} diff --git a/man/lognormal.Rd b/man/lognormal.Rd new file mode 100644 index 000000000..1cc20277a --- /dev/null +++ b/man/lognormal.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distribution_formulas.R +\name{lognormal} +\alias{lognormal} +\alias{multinomial} +\title{Distributions not available in the stats package} +\usage{ +lognormal(link = "log") + +multinomial(link = "logit") +} +\arguments{ +\item{link}{A string specifying the model link function. For example, +\code{"identity"} or \code{"log"} are appropriate names for the \code{\link[stats:family]{stats::gaussian()}} +distribution. \code{"log"} and \code{"logit"} are the defaults for the lognormal and +the multinomial, respectively.} +} +\value{ +An object of class \code{family} (which has a concise print method). This +particular family has a truncated length compared to other distributions in +\code{\link[stats:family]{stats::family()}}. +\item{family}{character: the family name.} +\item{link}{character: the link name.} +} +\description{ +Family objects provide a convenient way to specify the details of the models +used by functions such as \code{\link[stats:glm]{stats::glm()}}. These functions within this +package are not available within the stats package but are designed in a +similar manner. +} +\examples{ +a_family <- multinomial() +a_family[["family"]] +a_family[["link"]] +} +\seealso{ +\itemize{ +\item \code{\link[stats:family]{stats::family()}} +\item \code{\link[stats:family]{stats::gaussian()}} +\item \code{\link[stats:glm]{stats::glm()}} +\item \code{\link[stats:power]{stats::power()}} +\item \code{\link[stats:make.link]{stats::make.link()}} +} +} +\keyword{distribution} diff --git a/man/m_.Rd b/man/m_.Rd new file mode 100644 index 000000000..7af407ddb --- /dev/null +++ b/man/m_.Rd @@ -0,0 +1,85 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fimsframe.R +\name{m_} +\alias{m_} +\alias{m_landings} +\alias{m_landings,FIMSFrame-method} +\alias{m_landings,data.frame-method} +\alias{m_index} +\alias{m_index,FIMSFrame-method} +\alias{m_index,data.frame-method} +\alias{m_agecomp} +\alias{m_agecomp,FIMSFrame-method} +\alias{m_agecomp,data.frame-method} +\alias{m_lengthcomp} +\alias{m_lengthcomp,FIMSFrame-method} +\alias{m_lengthcomp,data.frame-method} +\alias{m_weight_at_age} +\alias{m_weight_at_age,FIMSFrame-method} +\alias{m_weight_at_age,data.frame-method} +\alias{m_age_to_length_conversion} +\alias{m_age_to_length_conversion,FIMSFrame-method} +\alias{m_age_to_length_conversion,data.frame-method} +\title{Get a vector of data to be passed to a FIMS module from a FIMSFrame object} +\usage{ +m_landings(x, fleet_name) + +\S4method{m_landings}{FIMSFrame}(x, fleet_name) + +\S4method{m_landings}{data.frame}(x, fleet_name) + +m_index(x, fleet_name) + +\S4method{m_index}{FIMSFrame}(x, fleet_name) + +\S4method{m_index}{data.frame}(x, fleet_name) + +m_agecomp(x, fleet_name) + +\S4method{m_agecomp}{FIMSFrame}(x, fleet_name) + +\S4method{m_agecomp}{data.frame}(x, fleet_name) + +m_lengthcomp(x, fleet_name) + +\S4method{m_lengthcomp}{FIMSFrame}(x, fleet_name) + +\S4method{m_lengthcomp}{data.frame}(x, fleet_name) + +m_weight_at_age(x) + +\S4method{m_weight_at_age}{FIMSFrame}(x) + +\S4method{m_weight_at_age}{data.frame}(x) + +m_age_to_length_conversion(x, fleet_name) + +\S4method{m_age_to_length_conversion}{FIMSFrame}(x, fleet_name) + +\S4method{m_age_to_length_conversion}{data.frame}(x, fleet_name) +} +\arguments{ +\item{x}{An object returned from \code{\link[=FIMSFrame]{FIMSFrame()}}.} + +\item{fleet_name}{A string, or vector of strings, specifying the name of the +fleet(s) of interest that you want landings data for. The strings must +exactly match strings in the column \code{"name"} of \code{get_data(x)}.} +} +\value{ +All of the \verb{m_*()} functions return vectors of data. Currently, the order of +the data is the same order as the data frame because no arranging is done in +\code{\link[=FIMSFrame]{FIMSFrame()}} and the function just extracts the appropriate column. +} +\description{ +There is an accessor function for each data type needed to run a FIMS model. +A FIMS model accepts vectors of data and thus each of the \verb{m_*()} functions, +where the star can be replaced with the data type separated by underscores, +e.g., weight_at_age. These accessor functions are the preferred way to pass +data to a FIMS module because the data will have the appropriate indexing. +} +\details{ +Age-to-length-conversion data, i.e., the proportion of age "a" that are +length "l", are used to convert lengths (input data) to ages (modeled) as +a way to fit length data without estimating growth. +} +\keyword{FIMSFrame} diff --git a/man/m_agecomp-FIMSFrame-method.Rd b/man/m_agecomp-FIMSFrame-method.Rd deleted file mode 100644 index f678b0f01..000000000 --- a/man/m_agecomp-FIMSFrame-method.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fimsframe.R -\name{m_agecomp,FIMSFrame-method} -\alias{m_agecomp,FIMSFrame-method} -\title{Get the age-composition data data to be used in the model} -\usage{ -\S4method{m_agecomp}{FIMSFrame}(x, fleet_name) -} -\arguments{ -\item{x}{The FIMSFrame containing age-composition data.} - -\item{fleet_name}{The name of the fleet for the age-composition data.} -} -\description{ -Get the age-composition data data to be used in the model -} diff --git a/man/m_agecomp.Rd b/man/m_agecomp.Rd deleted file mode 100644 index 9b3224c0f..000000000 --- a/man/m_agecomp.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fimsframe.R -\name{m_agecomp} -\alias{m_agecomp} -\title{Get the age-composition data to be used in the model} -\usage{ -m_agecomp(x, fleet_name) -} -\arguments{ -\item{x}{The object containing the age-composition data.} - -\item{fleet_name}{The name of the fleet for the age-composition data.} -} -\description{ -Get the age-composition data to be used in the model -} diff --git a/man/m_index-FIMSFrame-method.Rd b/man/m_index-FIMSFrame-method.Rd deleted file mode 100644 index f40b1323f..000000000 --- a/man/m_index-FIMSFrame-method.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fimsframe.R -\name{m_index,FIMSFrame-method} -\alias{m_index,FIMSFrame-method} -\title{Get the index data to be used in the model} -\usage{ -\S4method{m_index}{FIMSFrame}(x, fleet_name) -} -\arguments{ -\item{x}{The FIMSFrame object containing index.} - -\item{fleet_name}{The name of the fleet for the index data.} -} -\description{ -Get the index data to be used in the model -} diff --git a/man/m_index.Rd b/man/m_index.Rd deleted file mode 100644 index de027322c..000000000 --- a/man/m_index.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fimsframe.R -\name{m_index} -\alias{m_index} -\title{Get the index data to be used in the model} -\usage{ -m_index(x, fleet_name) -} -\arguments{ -\item{x}{The object containing index.} - -\item{fleet_name}{The name of the fleet for the index data.} -} -\description{ -Get the index data to be used in the model -} diff --git a/man/m_landings-FIMSFrame-method.Rd b/man/m_landings-FIMSFrame-method.Rd deleted file mode 100644 index 1eabcb134..000000000 --- a/man/m_landings-FIMSFrame-method.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fimsframe.R -\name{m_landings,FIMSFrame-method} -\alias{m_landings,FIMSFrame-method} -\title{Get the landings data to be used in the model} -\usage{ -\S4method{m_landings}{FIMSFrame}(x) -} -\arguments{ -\item{x}{The FIMSFrame object containing landings.} -} -\description{ -Get the landings data to be used in the model -} diff --git a/man/m_landings.Rd b/man/m_landings.Rd deleted file mode 100644 index 7788df664..000000000 --- a/man/m_landings.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fimsframe.R -\name{m_landings} -\alias{m_landings} -\title{Get the landings data to be used in the model} -\usage{ -m_landings(x) -} -\arguments{ -\item{x}{The object containing landings.} -} -\description{ -Get the landings data to be used in the model -} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index c8a1c77c1..8024129c5 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -21,6 +21,7 @@ articles: contents: - fims-documentation - fims-demo + - fims-logging - title: Developer contents: @@ -30,16 +31,28 @@ reference: - title: Data desc: > FIMS comes with a selection of built-in datasets that are used in - examples to illustrate various visualisation challenges. + examples to illustrate various visualization challenges. contents: - - data_mile1 + - data1 + +- title: Run FIMS + desc: Primary functions used when setting up or running a FIMS model. + contents: + - starts_with("FIMSFrame") + - starts_with("get_FIMSFrame") + - starts_with("m_") + - starts_with("create_default_") + - update_parameters + - has_keyword("distribution") + - starts_with("initialize_") + - has_keyword("fit_fims") + - is_fims_verbose - title: Package development desc: Primary functions used when developing FIMS package. contents: - has_keyword("gtest_helper") - - starts_with("FIMSFrame") - - starts_with("m_") + - has_keyword("set_methods") news: releases: diff --git a/src/Makevars b/src/Makevars index a3b36318d..099dc3939 100644 --- a/src/Makevars +++ b/src/Makevars @@ -1,4 +1,4 @@ -CXX_STD = CXX11 -PKG_CXXFLAGS = -DTMB_MODEL -DTMB_EIGEN_DISABLE_WARNINGS -w -CXX17STD = -std=c++11 -w - +CXX_STD = CXX17 +PKG_CXXFLAGS = -DTMB_MODEL -DTMB_EIGEN_DISABLE_WARNINGS +CXX17STD = -std=c++17 -w +USE_CXX17 = "yes" diff --git a/src/Makevars.win b/src/Makevars.win index ab39ecce2..8598441dd 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -1,6 +1,6 @@ -CXX_STD = CXX11 +CXX_STD = CXX17 PKG_CXXFLAGS = -DTMB_MODEL -DTMB_EIGEN_DISABLE_WARNINGS -CXX17STD = -std=c++11 +CXX17STD = -std=c++17 CXX14FLAGS = Wa, -mbig-obj -O3 CXX17FLAGS = Wa, -mbig-obj -O3 diff --git a/tests/concurrent/fims_concurrent_mpi.R b/tests/concurrent/fims_concurrent_mpi.R index aea829949..f11bba1e5 100644 --- a/tests/concurrent/fims_concurrent_mpi.R +++ b/tests/concurrent/fims_concurrent_mpi.R @@ -55,9 +55,6 @@ init_fims <- function(i) { # Recruitment recruitment <- new(fims$BevertonHoltRecruitment) - # logR_sd is NOT logged. It needs to enter the model logged b/c the exp() is taken - # before the likelihood calculation - recruitment$log_sigma_recruit$value <- log(om_input$logR_sd) recruitment$log_rzero$value <- log(om_input$R0 + runif(1, min = 0, max = 1000)) recruitment$log_rzero$is_random_effect <- FALSE recruitment$log_rzero$estimated <- FALSE @@ -110,7 +107,7 @@ init_fims <- function(i) { fishing_fleet <- new(fims$Fleet) fishing_fleet$nages <- om_input$nages fishing_fleet$nyears <- om_input$nyr - fishing_fleet$log_Fmort <- log(om_output$f) + fishing_fleet$log_Fmort <- new(VariableVector, log(om_output$f), om_input$nyr) fishing_fleet$estimate_F <- TRUE fishing_fleet$random_F <- FALSE fishing_fleet$log_q <- log(1.0) diff --git a/tests/concurrent/fims_concurrent_processR.R b/tests/concurrent/fims_concurrent_processR.R index 58472d40c..b48ab1f81 100644 --- a/tests/concurrent/fims_concurrent_processR.R +++ b/tests/concurrent/fims_concurrent_processR.R @@ -42,9 +42,6 @@ init_fims <- function(i) { # Recruitment recruitment <- new(fims$BevertonHoltRecruitment) - # logR_sd is NOT logged. It needs to enter the model logged b/c the exp() is taken - # before the likelihood calculation - recruitment$log_sigma_recruit$value <- log(om_input$logR_sd) recruitment$log_rzero$value <- log(om_input$R0 + runif(1, min = 0, max = 1000)) recruitment$log_rzero$is_random_effect <- FALSE recruitment$log_rzero$estimated <- FALSE @@ -97,7 +94,7 @@ init_fims <- function(i) { fishing_fleet <- new(fims$Fleet) fishing_fleet$nages <- om_input$nages fishing_fleet$nyears <- om_input$nyr - fishing_fleet$log_Fmort <- log(om_output$f) + fishing_fleet$input_type <- new(VariableVector, log(om_output$f), om_input$nyr) fishing_fleet$estimate_F <- TRUE fishing_fleet$random_F <- FALSE fishing_fleet$log_q <- log(1.0) @@ -125,7 +122,7 @@ init_fims <- function(i) { survey_fleet$is_survey <- TRUE survey_fleet$nages <- om_input$nages survey_fleet$nyears <- om_input$nyr - # survey_fleet$log_Fmort <- rep(log(0.0000000000000000000000000001), om_input$nyr) #-Inf? + # survey_fleet$input_type <- new(VariableVector, rep(log(0.0000000000000000000000000001), om_input$nyr), om_input$nyr) #-Inf? survey_fleet$estimate_F <- FALSE survey_fleet$random_F <- FALSE survey_fleet$log_q <- log(om_output$survey_q$survey1) diff --git a/tests/concurrent/fims_concurrent_snowfall.R b/tests/concurrent/fims_concurrent_snowfall.R index 8472bbcfa..c1c2a2d98 100644 --- a/tests/concurrent/fims_concurrent_snowfall.R +++ b/tests/concurrent/fims_concurrent_snowfall.R @@ -37,9 +37,6 @@ init_fims <- function(i) { # Recruitment recruitment <- new(fims$BevertonHoltRecruitment) - # logR_sd is NOT logged. It needs to enter the model logged b/c the exp() is taken - # before the likelihood calculation - recruitment$log_sigma_recruit$value <- log(om_input$logR_sd) recruitment$log_rzero$value <- log(om_input$R0) # + runif(1,min=0, max=1000)) recruitment$log_rzero$is_random_effect <- FALSE recruitment$log_rzero$estimated <- TRUE diff --git a/tests/gtest/integration_test_population.cpp b/tests/gtest/integration_test_population.cpp index 606f22eb2..88b33d46b 100644 --- a/tests/gtest/integration_test_population.cpp +++ b/tests/gtest/integration_test_population.cpp @@ -15,15 +15,15 @@ namespace // Declare IntegrationTest object IntegrationTest t(1, 1); std::stringstream ss; - typename JsonObject::iterator it; + typename fims::JsonObject::iterator it; bool good = true; // Read in input and output json files - JsonObject input; - JsonObject output; - JsonValue input_; - JsonValue output_; + fims::JsonObject input; + fims::JsonObject output; + fims::JsonValue input_; + fims::JsonValue output_; // Read inputs ss.str(""); @@ -72,14 +72,14 @@ namespace // Test unfished numbers at age, unfished spawning biomass, // and unfished biomass it = input.find("median_R0"); - JsonArray &R_0 = (*it).second.GetArray(); + fims::JsonArray &R_0 = (*it).second.GetArray(); // When obtaining the numeric values, GetDouble() will convert internal integer representation // to a double. Note that, int and unsigned can be safely converted to double, // but int64_t and uint64_t may lose precision (since mantissa of double is only 52-bits). double log_rzero = fims_math::log(R_0[0].GetDouble()); it = input.find("Phi.0"); - JsonArray &Phi0 = (*it).second.GetArray();; + fims::JsonArray &Phi0 = (*it).second.GetArray();; double phi_0 = Phi0[0].GetDouble(); for (int year = 0; year < pop.nyears; year++) @@ -123,7 +123,7 @@ namespace if (it != output.end()) { - JsonArray &e = (*it).second.GetArray();; + fims::JsonArray &e = (*it).second.GetArray();; for (int year = 0; year < pop.nyears; year++) { expected_spawning_biomass[year] = e[year].GetDouble(); @@ -153,7 +153,7 @@ namespace if (it != output.end()) { - JsonArray &e = (*it).second.GetArray();; + fims::JsonArray &e = (*it).second.GetArray();; for (int year = 0; year < pop.nyears; year++) { expected_biomass[year] = e[year].GetDouble(); @@ -180,9 +180,9 @@ namespace if (it != output.end()) { - typename JsonObject::iterator fleet1; + typename fims::JsonObject::iterator fleet1; fleet1 = it->second.GetObject().find("fleet1"); - JsonArray &fleet_catch = (*fleet1).second.GetArray(); + fims::JsonArray &fleet_catch = (*fleet1).second.GetArray(); for (int year = 0; year < pop.nyears; year++) { expected_catch[year] = fleet_catch[year].GetDouble(); @@ -207,21 +207,21 @@ namespace // Test expected index it = output.find("survey_q"); - typename JsonObject::iterator fleet2_q; + typename fims::JsonObject::iterator fleet2_q; fleet2_q = it->second.GetObject().find("survey1"); - JsonArray&fleet_q = (*fleet2_q).second.GetArray(); + fims::JsonArray&fleet_q = (*fleet2_q).second.GetArray(); it = output.find("survey_index_biomass"); if (it != output.end()) { - typename JsonObject::iterator fleet2_index; + typename fims::JsonObject::iterator fleet2_index; fleet2_index = it->second.GetObject().find("survey1"); - JsonArray &fleet_index = (*fleet2_index).second.GetArray(); - EXPECT_EQ(pop.fleets[0]->q, 1.0); + fims::JsonArray &fleet_index = (*fleet2_index).second.GetArray(); + EXPECT_EQ(pop.fleets[0]->q[0], 1.0); // Do not use EXPECT_EQ to compare floats or doubles // Use EXPECT_NEAR here - EXPECT_NEAR(pop.fleets[1]->q, fleet_q[0].GetDouble(), 1.0e-07); + EXPECT_NEAR(pop.fleets[1]->q[0], fleet_q[0].GetDouble(), 1.0e-07); if(pop.fleets[1]->is_survey){ for (int year = 0; year < pop.nyears; year++) @@ -256,7 +256,7 @@ namespace it = output.find("N.age"); if (it != output.end()) { - JsonArray &e = (*it).second.GetArray(); + fims::JsonArray &e = (*it).second.GetArray(); for (int year = 0; year < pop.nyears; year++) { for (int age = 0; age < pop.nages; age++) @@ -298,7 +298,7 @@ namespace it = output.find("FAA"); if (it != output.end()) { - JsonArray &e = (*it).second.GetArray(); + fims::JsonArray &e = (*it).second.GetArray(); for (int year = 0; year < pop.nyears; year++) { for (int age = 0; age < pop.nages; age++) @@ -322,7 +322,7 @@ namespace // integration_test_log <<"test"<q* + population.fleets[fleet_]->q[0]* population.fleets[fleet_]->selectivity->evaluate(population.ages[age])* population.growth->evaluate(population.ages[age]); diff --git a/tests/gtest/test_population_Unfished_Initial.cpp b/tests/gtest/test_population_Unfished_Initial.cpp index cca28de6e..fb195ec90 100644 --- a/tests/gtest/test_population_Unfished_Initial.cpp +++ b/tests/gtest/test_population_Unfished_Initial.cpp @@ -20,7 +20,6 @@ namespace { if(!population.fleets[fleet_index]->is_survey){ // Known values were used to generate "true" value and test CalculateMortality() - size_t index_yf = year * population.nfleets + fleet_index; mortality_F[i_age_year] += population.fleets[fleet_index]->Fmort[year] * population.fleets[fleet_index]->selectivity->evaluate(population.ages[age]); @@ -69,8 +68,8 @@ namespace if (age == 0) { - population.unfished_numbers_at_age[i_age_year] = fims_math::exp(population.recruitment->log_rzero); - test_unfished_numbers_at_age[i_age_year] = fims_math::exp(population.recruitment->log_rzero); + population.unfished_numbers_at_age[i_age_year] = fims_math::exp(population.recruitment->log_rzero[0]); + test_unfished_numbers_at_age[i_age_year] = fims_math::exp(population.recruitment->log_rzero[0]); } if (year == 0 && age > 0){ diff --git a/tests/gtest/test_population_dynamics_fleet_initialize_prepare.cpp b/tests/gtest/test_population_dynamics_fleet_initialize_prepare.cpp index af1451172..9d4b68d2a 100644 --- a/tests/gtest/test_population_dynamics_fleet_initialize_prepare.cpp +++ b/tests/gtest/test_population_dynamics_fleet_initialize_prepare.cpp @@ -9,7 +9,10 @@ namespace { fims_popdy::Fleet fleet; int nyears = 30; - int nages = 12; + int nages = 12; + fleet.expected_catch.resize(nyears); + fleet.expected_index.resize(nyears); + fleet.catch_numbers_at_age.resize(nyears * nages); fleet.Initialize(nyears, nages); fleet.Prepare(); @@ -25,6 +28,10 @@ namespace fims_popdy::Fleet fleet; int nyears = 30; int nages = 12; + fleet.expected_catch.resize(nyears); + fleet.expected_index.resize(nyears); + fleet.catch_numbers_at_age.resize(nyears * nages); + fleet.log_q.resize(1);//needs to be initialized here, size used by q in Initialize fleet.Initialize(nyears, nages); int seed = 1234; @@ -38,17 +45,19 @@ namespace double log_q_min = fims_math::log(0.1); double log_q_max = fims_math::log(1); std::uniform_real_distribution log_q_distribution(log_q_min, log_q_max); - fleet.log_q = log_q_distribution(generator); + + fleet.log_q[0] = log_q_distribution(generator); for(int i = 0; i < nyears; i++) { fleet.log_Fmort[i] = log_Fmort_distribution(generator); } + fleet.Prepare(); // Test fleet.Fmort and fleet.q std::vector Fmort(nyears, 0); - double q = fims_math::exp(fleet.log_q); - EXPECT_EQ(fleet.q, q); + double q = fims_math::exp(fleet.log_q[0]); + EXPECT_EQ(fleet.q[0], q); for (int i = 0; i < nyears; i++) { Fmort[i] = fims_math::exp(fleet.log_Fmort[i]); diff --git a/tests/gtest/test_population_dynamics_maturity_logistic.cpp b/tests/gtest/test_population_dynamics_maturity_logistic.cpp index 3997aa0fa..9912706a3 100644 --- a/tests/gtest/test_population_dynamics_maturity_logistic.cpp +++ b/tests/gtest/test_population_dynamics_maturity_logistic.cpp @@ -4,13 +4,15 @@ namespace { - + TEST(LogisticMaturity, CreateObject) { - + fims_popdy::LogisticMaturity maturity; - maturity.inflection_point = 20.5; - maturity.slope = 0.15; + maturity.inflection_point.resize(1); + maturity.inflection_point[0] = 20.5; + maturity.slope.resize(1); + maturity.slope[0] = 0.15; double maturity_x = 40.5; // 1.0/(1.0+exp(-(40.5-20.5)*0.15)) = 0.9525741 double expect_maturity = 0.9525741; @@ -19,4 +21,4 @@ namespace } -} \ No newline at end of file +} diff --git a/tests/gtest/test_population_dynamics_population_initialize_prepare.cpp b/tests/gtest/test_population_dynamics_population_initialize_prepare.cpp index fc6c9148a..f87e3edd5 100644 --- a/tests/gtest/test_population_dynamics_population_initialize_prepare.cpp +++ b/tests/gtest/test_population_dynamics_population_initialize_prepare.cpp @@ -16,6 +16,7 @@ namespace TEST_F(PopulationInitializeTestFixture, Initialize_works) { + population.numbers_at_age.resize((nyears + 1) * nages); population.Initialize(nyears, nseasons, nages); EXPECT_EQ(population.nfleets, nfleets); diff --git a/tests/gtest/test_population_dynamics_selectivity_double_logistic.cpp b/tests/gtest/test_population_dynamics_selectivity_double_logistic.cpp index 76a14274e..41783a3ab 100644 --- a/tests/gtest/test_population_dynamics_selectivity_double_logistic.cpp +++ b/tests/gtest/test_population_dynamics_selectivity_double_logistic.cpp @@ -8,10 +8,14 @@ namespace { fims_popdy::DoubleLogisticSelectivity fishery_selectivity; - fishery_selectivity.inflection_point_asc = 10.5; - fishery_selectivity.slope_asc = 0.2; - fishery_selectivity.inflection_point_desc = 15.0; - fishery_selectivity.slope_desc = 0.05; + fishery_selectivity.inflection_point_asc.resize(1); + fishery_selectivity.slope_asc.resize(1); + fishery_selectivity.inflection_point_desc.resize(1); + fishery_selectivity.slope_desc.resize(1); + fishery_selectivity.inflection_point_asc[0] = 10.5; + fishery_selectivity.slope_asc[0] = 0.2; + fishery_selectivity.inflection_point_desc[0] = 15.0; + fishery_selectivity.slope_desc[0] = 0.05; double fishery_x = 34.5; // 1.0/(1.0+exp(-(34.5-10.5)*0.2)) * (1.0 - 1.0/(1.0+exp(-(34.5-15.0)*0.05))) = 0.2716494 double expect_fishery = 0.2716494; diff --git a/tests/gtest/test_population_dynamics_selectivity_logistic.cpp b/tests/gtest/test_population_dynamics_selectivity_logistic.cpp index 7dcffa907..ed0c72c47 100644 --- a/tests/gtest/test_population_dynamics_selectivity_logistic.cpp +++ b/tests/gtest/test_population_dynamics_selectivity_logistic.cpp @@ -9,8 +9,10 @@ namespace { fims_popdy::LogisticSelectivity fishery_selectivity; - fishery_selectivity.inflection_point = 20.5; - fishery_selectivity.slope = 0.2; + fishery_selectivity.inflection_point.resize(1); + fishery_selectivity.slope.resize(1); + fishery_selectivity.inflection_point[0] = 20.5; + fishery_selectivity.slope[0] = 0.2; double fishery_x = 40.5; // 1.0/(1.0+exp(-(40.5-20.5)*0.2)) = 0.9820138 double expect_fishery = 0.9820138; diff --git a/tests/gtest/test_population_test_fixture.hpp b/tests/gtest/test_population_test_fixture.hpp index cc20f8c10..3dcfd4533 100644 --- a/tests/gtest/test_population_test_fixture.hpp +++ b/tests/gtest/test_population_test_fixture.hpp @@ -2,6 +2,9 @@ #include "population_dynamics/population/population.hpp" + + + namespace { // Use test fixture to reuse the same configuration of objects for @@ -22,6 +25,7 @@ class PopulationInitializeTestFixture : public testing::Test { population.nages = nages; for (int i = 0; i < nfleets; i++) { auto fleet = std::make_shared>(); + fleet->log_q.resize(1); population.fleets.push_back(fleet); } } @@ -79,12 +83,18 @@ class PopulationEvaluateTestFixture : public testing::Test { auto fleet = std::make_shared>(); auto selectivity = std::make_shared>(); - selectivity->inflection_point = 7; - selectivity->slope = 0.5; - + selectivity->inflection_point.resize(1); + selectivity->inflection_point[0] = 7; + selectivity->slope.resize(1); + selectivity->slope[0] = 0.5; + + fleet->expected_catch.resize(nyears); + fleet->expected_index.resize(nyears); + fleet->catch_numbers_at_age.resize(nyears * nages); + fleet->log_q.resize(1); fleet->Initialize(nyears, nages); fleet->selectivity = selectivity; - fleet->log_q = log_q_distribution(generator); + fleet->log_q[0] = log_q_distribution(generator); for (int year = 0; year < nyears; year++) { fleet->log_Fmort[year] = log_Fmort_distribution(generator); } @@ -94,8 +104,12 @@ class PopulationEvaluateTestFixture : public testing::Test { fleet->Prepare(); population.fleets.push_back(fleet); } - - population.Initialize(nyears, nseasons, nages); + population.numbers_at_age.resize((nyears + 1) * nages); + try { + population.Initialize(nyears, nseasons, nages); + } catch (std::exception& e) { + std::cout << e.what() << "\n"; + } for (int i = 0; i < nages; i++) { population.ages[i] = i + 1; @@ -154,13 +168,17 @@ class PopulationEvaluateTestFixture : public testing::Test { population.Prepare(); auto maturity = std::make_shared>(); - maturity->inflection_point = 6; - maturity->slope = 0.15; + maturity->inflection_point.resize(1); + maturity->inflection_point[0] = 6; + maturity->slope.resize(1); + maturity->slope[0] = 0.15; population.maturity = maturity; auto recruitment = std::make_shared>(); - recruitment->logit_steep = fims_math::logit(0.2, 1.0, 0.75); - recruitment->log_rzero = fims_math::log(1000000.0); + recruitment->logit_steep.resize(1); + recruitment->log_rzero.resize(1); + recruitment->logit_steep[0] = fims_math::logit(0.2, 1.0, 0.75); + recruitment->log_rzero[0] = fims_math::log(1000000.0); /*the log_recruit_dev vector does not include a value for year == 0 and is of length nyears - 1 where the first position of the vector corresponds to the second year of the time series.*/ @@ -229,12 +247,18 @@ class PopulationPrepareTestFixture : public testing::Test { auto fleet = std::make_shared>(); auto selectivity = std::make_shared>(); - selectivity->inflection_point = 7; - selectivity->slope = 0.5; - + selectivity->inflection_point.resize(1); + selectivity->slope.resize(1); + selectivity->inflection_point[0] = 7; + selectivity->slope[0] = 0.5; + + fleet->expected_catch.resize(nyears); + fleet->expected_index.resize(nyears); + fleet->catch_numbers_at_age.resize(nyears * nages); + fleet->log_q.resize(1); fleet->Initialize(nyears, nages); fleet->selectivity = selectivity; - fleet->log_q = log_q_distribution(generator); + fleet->log_q[0] = log_q_distribution(generator); for (int year = 0; year < nyears; year++) { fleet->log_Fmort[year] = log_Fmort_distribution(generator); } @@ -245,6 +269,7 @@ class PopulationPrepareTestFixture : public testing::Test { population.fleets.push_back(fleet); } + population.numbers_at_age.resize((nyears + 1) * nages); population.Initialize(nyears, nseasons, nages); for (int i = 0; i < nages; i++) { diff --git a/tests/gtest/test_sr_beverton_holt.cpp b/tests/gtest/test_sr_beverton_holt.cpp index 4b2f253c9..e746bb4b2 100644 --- a/tests/gtest/test_sr_beverton_holt.cpp +++ b/tests/gtest/test_sr_beverton_holt.cpp @@ -14,11 +14,12 @@ namespace // BH_fcn(R0 = 1000, h = 0.99, phi0 = 0.2, x = 40): 990 fims_popdy::SRBevertonHolt recruit1; - - recruit1.logit_steep = fims_math::logit(0.2, 1.0, 0.7500); + recruit1.logit_steep.resize(1); + recruit1.logit_steep[0] = fims_math::logit(0.2, 1.0, 0.7500); // The R0 value (1 thousand) here is for this unit test. // It is different than the Model Comparison Project value (1 million). - recruit1.log_rzero = std::log(1000.000); + recruit1.log_rzero.resize(1); + recruit1.log_rzero[0] = std::log(1000.000); double spawners = 30.000; double phi_0 = 0.1; // # R code that generates true values for testing @@ -36,8 +37,10 @@ namespace EXPECT_EQ(recruit1.GetId(), 0); fims_popdy::SRBevertonHolt recruit2; - recruit2.logit_steep = fims_math::logit(0.2, 1.0, 0.200); - recruit2.log_rzero = std::log(1000.000); + recruit2.logit_steep.resize(1); + recruit2.logit_steep[0] = fims_math::logit(0.2, 1.0, 0.200); + recruit2.log_rzero.resize(1); + recruit2.log_rzero[0] = std::log(1000.000); double spawners2 = 40.000; double phi_02 = 0.2; // # R code that generates true values for testing diff --git a/tests/integration/integration_class.hpp b/tests/integration/integration_class.hpp index 96a9edf31..54fa0589b 100644 --- a/tests/integration/integration_class.hpp +++ b/tests/integration/integration_class.hpp @@ -29,8 +29,8 @@ class IntegrationTest { std::stringstream ss; for (uint32_t i = 0; i < this->ncases_m; i++) { for (uint32_t j = 0; j < this->ninput_files_m; j++) { - JsonValue input; - JsonValue output; + fims::JsonValue input; + fims::JsonValue output; ss.str(""); ss << "inputs/C" << i << "/om_input" << j + 1 << ".json"; @@ -46,7 +46,11 @@ class IntegrationTest { good = false; } + if(good){ this->RunModelLoop(pop, input); + }else{ + throw std::invalid_argument("model not good!"); + } // if (!this->CheckModelOutput(pop, output)) { // good = false; @@ -58,7 +62,7 @@ class IntegrationTest { } bool ReadJson(const std::string &path, - JsonValue &result) { + fims::JsonValue &result) { std::stringstream ss; std::ifstream infile; @@ -76,7 +80,7 @@ class IntegrationTest { // std::cout << ss.str() << "\n"; } - JsonParser parser; + fims::JsonParser parser; result = parser.Parse(ss.str()); parser.WriteToFile("out.json", result); // json_.Parse(ss.str().c_str()); @@ -85,25 +89,25 @@ class IntegrationTest { } bool ConfigurePopulationModel(fims_popdy::Population &pop, - JsonValue &input, - JsonValue &output) { + fims::JsonValue &input, + fims::JsonValue &output) { std::cout << input.GetType() << "\n"; size_t nfleets, nsurveys, nages, nyears; std::cout << input.GetDouble() << "\n"; - if (input.GetType() == JsonValueType::Object && output.GetType() == JsonValueType::Object) { + if (input.GetType() == fims::JsonValueType::Object && output.GetType() == fims::JsonValueType::Object) { - JsonObject& obj = input.GetObject(); - JsonObject& obj2 = output.GetObject(); + fims::JsonObject& obj = input.GetObject(); + fims::JsonObject& obj2 = output.GetObject(); - typename JsonObject::iterator it; + typename fims::JsonObject::iterator it; it = obj.find("nyr"); if (it != obj.end()) { - JsonValue e = (*it).second; - if (e.GetType() == JsonValueType::Array) { - JsonArray a = e.GetArray(); + fims::JsonValue e = (*it).second; + if (e.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a = e.GetArray(); nyears = a[0].GetInt(); } @@ -121,9 +125,9 @@ class IntegrationTest { it = obj.find("nages"); if (it != obj.end()) { - JsonValue e = (*it).second; - if (e.GetType() == JsonValueType::Array) { - JsonArray a = e.GetArray(); + fims::JsonValue e = (*it).second; + if (e.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a = e.GetArray(); nages = a[0].GetInt(); } @@ -140,9 +144,9 @@ class IntegrationTest { //get number of fleets it = obj.find("fleet_num"); if (it != obj.end()) { - JsonValue e = (*it).second; - if (e.GetType() == JsonValueType::Array) { - JsonArray a = e.GetArray(); + fims::JsonValue e = (*it).second; + if (e.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a = e.GetArray(); nfleets = a[0].GetInt(); } @@ -152,27 +156,28 @@ class IntegrationTest { for (size_t i = 0; i < nfleets; i++) { std::shared_ptr > f = std::make_shared >(); + f->log_q.resize(1); f->Initialize(nyears, nages); - f->observed_index_data = std::make_shared >(nyears); - f->observed_agecomp_data = std::make_shared >(nyears, nages); + // f->observed_index_data = std::make_shared >(nyears); + // f->observed_agecomp_data = std::make_shared >(nyears, nages); std::stringstream strs; strs << "fleet" << i + 1; it = obj.find("sel_fleet"); - typename JsonObject::iterator fsel; + typename fims::JsonObject::iterator fsel; if (it != obj.end()) { - JsonValue e = (*it).second; - if (e.GetType() == JsonValueType::Object) { - JsonObject o = e.GetObject(); + fims::JsonValue e = (*it).second; + if (e.GetType() == fims::JsonValueType::Object) { + fims::JsonObject o = e.GetObject(); fsel = o.find(strs.str().c_str()); - if ((*fsel).second.GetType() == JsonValueType::Object) { - JsonObject fsel_o = (*fsel).second.GetObject(); + if ((*fsel).second.GetType() == fims::JsonValueType::Object) { + fims::JsonObject fsel_o = (*fsel).second.GetObject(); it = fsel_o.find("pattern"); - if ((*it).second.GetType() == JsonValueType::Array) { + if ((*it).second.GetType() == fims::JsonValueType::JArray) { - JsonArray sel_pattern = (*it).second.GetArray(); + fims::JsonArray sel_pattern = (*it).second.GetArray(); if (print_statements) { std::cout << "Selectivity:\n"; } @@ -183,20 +188,22 @@ class IntegrationTest { std::shared_ptr > selectivity = std::make_shared >(); it = fsel_o.find("A50.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray a50 = (*it).second.GetArray(); - selectivity->inflection_point = a50[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a50 = (*it).second.GetArray(); + selectivity->inflection_point.resize(1); + selectivity->inflection_point[0] = a50[0].GetDouble(); if (print_statements) { - std::cout << "A50 " << selectivity->inflection_point << "\n"; + std::cout << "A50 " << selectivity->inflection_point[0] << "\n"; } } it = fsel_o.find("slope.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray slope = (*it).second.GetArray(); - selectivity->slope = slope[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray slope = (*it).second.GetArray(); + selectivity->slope.resize(1); + selectivity->slope[0] = slope[0].GetDouble(); if (print_statements) { - std::cout << "slope " << selectivity->slope << "\n"; + std::cout << "slope " << selectivity->slope[0] << "\n"; } } @@ -210,38 +217,42 @@ class IntegrationTest { std::shared_ptr > selectivity = std::make_shared >(); it = fsel_o.find("A50.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray a50 = (*it).second.GetArray(); - selectivity->inflection_point_asc = a50[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a50 = (*it).second.GetArray(); + selectivity->inflection_point_asc.resize(1); + selectivity->inflection_point_asc[0] = a50[0].GetDouble(); if (print_statements) { - std::cout << "A50 asc " << selectivity->inflection_point_asc << "\n"; + std::cout << "A50 asc " << selectivity->inflection_point_asc[0] << "\n"; } } it = fsel_o.find("slope.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray slope = (*it).second.GetArray(); - selectivity->slope_asc = slope[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray slope = (*it).second.GetArray(); + selectivity->slope_asc.resize(1); + selectivity->slope_asc[0] = slope[0].GetDouble(); if (print_statements) { - std::cout << "slope asc " << selectivity->slope_asc << "\n"; + std::cout << "slope asc " << selectivity->slope_asc[0] << "\n"; } } it = fsel_o.find("A50.sel2"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray a50 = (*it).second.GetArray(); - selectivity->inflection_point_desc = a50[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a50 = (*it).second.GetArray(); + selectivity->inflection_point_desc.resize(1); + selectivity->inflection_point_desc[0] = a50[0].GetDouble(); if (print_statements) { - std::cout << "A50 desc " << selectivity->inflection_point_desc << "\n"; + std::cout << "A50 desc " << selectivity->inflection_point_desc[0] << "\n"; } } it = fsel_o.find("slope.sel2"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray slope = (*it).second.GetArray(); - selectivity->slope_desc = slope[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray slope = (*it).second.GetArray(); + selectivity->slope_desc.resize(1); + selectivity->slope_desc[0] = slope[0].GetDouble(); if (print_statements) { - std::cout << "slope desc " << selectivity->slope_desc << "\n"; + std::cout << "slope desc " << selectivity->slope_desc[0] << "\n"; } } f->selectivity = selectivity; @@ -255,10 +266,10 @@ class IntegrationTest { } - f->log_q = 0.0; + f->log_q[0] = 0.0; it = obj.find("f"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray f_values = (*it).second.GetArray(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray f_values = (*it).second.GetArray(); for (int i = 0; i < f_values.size(); i++) { f->Fmort[i] = f_values[i].GetDouble(); f->log_Fmort[i] = std::log(f_values[i].GetDouble()); @@ -283,9 +294,9 @@ class IntegrationTest { it = obj.find("survey_num"); if (it != obj.end()) { - JsonValue e = (*it).second; - if (e.GetType() == JsonValueType::Array) { - JsonArray a = e.GetArray(); + fims::JsonValue e = (*it).second; + if (e.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a = e.GetArray(); nsurveys = a[0].GetInt(); } @@ -296,44 +307,47 @@ class IntegrationTest { for (size_t i = 0; i < nsurveys; i++) { std::shared_ptr > s = std::make_shared >(); s->is_survey = true; + s->log_q.resize(1); s->Initialize(nyears, nages); - s->observed_index_data = std::make_shared >(nyears); - s->observed_agecomp_data = std::make_shared >(nyears, nages); + // s->observed_index_data = std::make_shared >(nyears); + // s->observed_agecomp_data = std::make_shared >(nyears, nages); std::stringstream strs; strs << "survey" << i + 1; it = obj.find("sel_survey"); - typename JsonObject::iterator fsel; + typename fims::JsonObject::iterator fsel; if (it != obj.end()) { - JsonValue e = (*it).second; - if (e.GetType() == JsonValueType::Object) { - JsonObject o = e.GetObject(); + fims::JsonValue e = (*it).second; + if (e.GetType() == fims::JsonValueType::Object) { + fims::JsonObject o = e.GetObject(); fsel = o.find(strs.str().c_str()); - - if ((*fsel).second.GetType() == JsonValueType::Object) { + + if ((*fsel).second.GetType() == fims::JsonValueType::Object) { - JsonObject fsel_o = (*fsel).second.GetObject(); + fims::JsonObject fsel_o = (*fsel).second.GetObject(); it = fsel_o.find("pattern"); - if ((*it).second.GetType() == JsonValueType::Array) { + if ((*it).second.GetType() == fims::JsonValueType::JArray) { - JsonArray sel_pattern = (*it).second.GetArray(); + fims::JsonArray sel_pattern = (*it).second.GetArray(); if (sel_pattern[0].GetInt() == 1) {//logistic std::shared_ptr > selectivity = std::make_shared >(); it = fsel_o.find("A50.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray a50 = (*it).second.GetArray(); - selectivity->inflection_point = a50[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a50 = (*it).second.GetArray(); + selectivity->inflection_point.resize(1); + selectivity->inflection_point[0] = a50[0].GetDouble(); } it = fsel_o.find("slope.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray slope = (*it).second.GetArray(); - selectivity->slope = slope[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray slope = (*it).second.GetArray(); + selectivity->slope.resize(1); + selectivity->slope[0] = slope[0].GetDouble(); } s->selectivity = selectivity; @@ -344,27 +358,31 @@ class IntegrationTest { std::shared_ptr > selectivity = std::make_shared >(); it = fsel_o.find("A50.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray a50 = (*it).second.GetArray(); - selectivity->inflection_point_asc = a50[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a50 = (*it).second.GetArray(); + selectivity->inflection_point_asc.resize(1); + selectivity->inflection_point_asc[0] = a50[0].GetDouble(); } it = fsel_o.find("slope.sel1"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray slope = (*it).second.GetArray(); - selectivity->slope_asc = slope[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray slope = (*it).second.GetArray(); + selectivity->slope_asc.resize(1); + selectivity->slope_asc[0] = slope[0].GetDouble(); } it = fsel_o.find("A50.sel2"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray a50 = (*it).second.GetArray(); - selectivity->inflection_point_desc = a50[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a50 = (*it).second.GetArray(); + selectivity->inflection_point_desc.resize(1); + selectivity->inflection_point_desc[0] = a50[0].GetDouble(); } it = fsel_o.find("slope.sel2"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray slope = (*it).second.GetArray(); - selectivity->slope_desc = slope[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray slope = (*it).second.GetArray(); + selectivity->slope_desc.resize(1); + selectivity->slope_desc[0] = slope[0].GetDouble(); } s->selectivity = selectivity; } @@ -377,19 +395,19 @@ class IntegrationTest { } - s->log_q = 0.0; + s->log_q[0] = 0.0; it = obj2.find("survey_q"); - if ((*it).second.GetType() == JsonValueType::Object) { + if ((*it).second.GetType() == fims::JsonValueType::Object) { // f->log_q = fims_math::log((*it).second.GetDouble()); - JsonObject qobj = (*it).second.GetObject(); + fims::JsonObject qobj = (*it).second.GetObject(); - typename JsonObject::iterator qit = qobj.find("survey1"); + typename fims::JsonObject::iterator qit = qobj.find("survey1"); - if ((*qit).second.GetType() == JsonValueType::Array) { - JsonArray a = (*qit).second.GetArray(); - s->log_q = fims_math::log(a[0].GetDouble()); + if ((*qit).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray a = (*qit).second.GetArray(); + s->log_q[0] = fims_math::log(a[0].GetDouble()); if (this->print_statements) { std::cout << "q = " << a[0].GetDouble() << "\nlog(q) = " << s->log_q << "\n"; } @@ -411,15 +429,16 @@ class IntegrationTest { pop.nfleets = pop.fleets.size(); // initialize population + pop.numbers_at_age.resize((nyears + 1) * nages); pop.Initialize(nyears, 1, nages); // Set initial size to value from MCP C0 it = obj2.find("N.age"); if (it != obj2.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray n = (*it).second.GetArray(); - if (n[0].GetType() == JsonValueType::Array) { - JsonArray init_n = n[0].GetArray(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray n = (*it).second.GetArray(); + if (n[0].GetType() == fims::JsonValueType::JArray) { + fims::JsonArray init_n = n[0].GetArray(); for (size_t i = 0; i < pop.nages; i++) { pop.log_init_naa[i] = std::log(init_n[i].GetDouble()); } @@ -430,11 +449,11 @@ class IntegrationTest { it = obj.find("ages"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { + if ((*it).second.GetType() == fims::JsonValueType::JArray) { if (print_statements) { std::cout << "ages: "; } - JsonArray ages = (*it).second.GetArray(); + fims::JsonArray ages = (*it).second.GetArray(); for (int i = 0; i < ages.size(); i++) { pop.ages[i] = ages[i].GetDouble(); if (print_statements) { @@ -456,11 +475,11 @@ class IntegrationTest { it = obj.find("year"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { + if ((*it).second.GetType() == fims::JsonValueType::JArray) { if (print_statements) { std::cout << "year: "; } - JsonArray years = (*it).second.GetArray(); + fims::JsonArray years = (*it).second.GetArray(); for (int i = 0; i < years.size(); i++) { pop.years[i] = years[i].GetDouble(); if (print_statements) { @@ -482,8 +501,8 @@ class IntegrationTest { std::cout << "\nMortality:\n"; } it = obj.find("M"); - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray m = (*it).second.GetArray(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray m = (*it).second.GetArray(); double log_M = std::log(m[0].GetDouble()); std::fill(pop.log_M.begin(), pop.log_M.end(), log_M); if (print_statements) { @@ -505,11 +524,12 @@ class IntegrationTest { } it = obj.find("R0"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { + if ((*it).second.GetType() ==fims::JsonValueType::JArray) { double r0 = (*it).second.GetArray()[0].GetDouble(); - rec->log_rzero = std::log(r0); + rec->log_rzero.resize(1); + rec->log_rzero[0] = std::log(r0); if (print_statements) { - std::cout << "R0 " << rec->log_rzero << "| \n"; + std::cout << "R0 " << rec->log_rzero[0] << "| \n"; } } } else { @@ -520,10 +540,11 @@ class IntegrationTest { it = obj.find("h"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - rec->logit_steep = fims_math::logit(0.2, 1.0, (*it).second.GetArray()[0].GetDouble()); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + rec->logit_steep.resize(1); + rec->logit_steep[0] = fims_math::logit(0.2, 1.0, (*it).second.GetArray()[0].GetDouble()); if (print_statements) { - std::cout << "'h' " << rec->logit_steep << " \n"; + std::cout << "'h' " << rec->logit_steep[0] << " \n"; } } } else { @@ -532,21 +553,6 @@ class IntegrationTest { } } - it = obj.find("logR_sd"); - if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - rec->log_sigma_recruit = (*it).second.GetArray()[0].GetDouble(); - if (print_statements) { - std::cout << "'SD' " << rec->log_sigma_recruit << " \n"; - } - } - } else { - if (print_statements) { - std::cout << "'logR_sd' not found.\n"; - } - } - - it = obj.find("logR.resid"); /*the log_recruit_dev vector does not include a value for year == 0 and is of length nyears - 1 where the first position of the vector @@ -554,8 +560,8 @@ class IntegrationTest { rec->log_recruit_devs.resize(nyears); std::fill(rec->log_recruit_devs.begin(), rec->log_recruit_devs.end(), 0.0); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray rdev = (*it).second.GetArray(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray rdev = (*it).second.GetArray(); if (print_statements) { std::cout << "recruitment deviations: "; } @@ -585,10 +591,11 @@ class IntegrationTest { } it = obj.find("A50.mat"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - mat->inflection_point = (*it).second.GetArray()[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + mat->inflection_point.resize(1); + mat->inflection_point[0] = (*it).second.GetArray()[0].GetDouble(); if (print_statements) { - std::cout << "inflection_point " << mat->inflection_point << " \n"; + std::cout << "inflection_point.mat " << mat->inflection_point[0] << " \n"; } } } else { @@ -596,15 +603,16 @@ class IntegrationTest { std::cout << "'A50.mat' not found.\n"; } } - + pop.maturity = mat; it = obj.find("slope.mat"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - mat->slope = (*it).second.GetArray()[0].GetDouble(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + mat->slope.resize(1); + mat->slope[0] = (*it).second.GetArray()[0].GetDouble(); if (print_statements) { - std::cout << "slope " << mat->slope << " \n"; + std::cout << "slope.mat " << mat->slope[0] << " \n"; } } } else { @@ -619,8 +627,8 @@ class IntegrationTest { it = obj.find("W.kg"); if (it != obj.end()) { - if ((*it).second.GetType() == JsonValueType::Array) { - JsonArray wt = (*it).second.GetArray(); + if ((*it).second.GetType() == fims::JsonValueType::JArray) { + fims::JsonArray wt = (*it).second.GetArray(); if (print_statements) { std::cout << "W.kg: "; } @@ -649,12 +657,12 @@ class IntegrationTest { } std::vector RunModelLoop(fims_popdy::Population &pop, - const JsonValue & input) { + const fims::JsonValue & input) { + + fims::JsonObject output; + fims::JsonArray array; - JsonObject output; - JsonArray array; - pop.Evaluate(); @@ -672,9 +680,9 @@ class IntegrationTest { std::cout << std::endl; } } - + output["NumbersAtAge"] = array; - + if (print_statements) { std::cout << "\n\n" << std::endl; @@ -685,7 +693,7 @@ class IntegrationTest { } bool CheckModelOutput(fims_popdy::Population &pop, - JsonValue &output) { + fims::JsonValue &output) { return true; } }; diff --git a/tests/integration/integration_test_population_tmb_nointerface.R b/tests/integration/integration_test_population_tmb_nointerface.R index 4ce5d3475..a68e4dce7 100644 --- a/tests/integration/integration_test_population_tmb_nointerface.R +++ b/tests/integration/integration_test_population_tmb_nointerface.R @@ -21,8 +21,8 @@ compile(paste0(path, "integration_test_population_tmb_nointerface.cpp"), dyn.load(dynlib(paste0(path, "integration_test_population_tmb_nointerface"))) # Need code chunk below to run with data: -# data(package = "FIMS") -# fims_frame <- FIMSFrame(data_mile1) +# data("data1", package = "FIMS") +# fims_frame <- FIMSFrame(data1) naa <- c( 993947.488, 811707.7933, 661434.4148, 537804.7782, diff --git a/tests/integration/integration_test_population_tmb_nointerface.cpp b/tests/integration/integration_test_population_tmb_nointerface.cpp index 46b19b667..12f6c0a60 100644 --- a/tests/integration/integration_test_population_tmb_nointerface.cpp +++ b/tests/integration/integration_test_population_tmb_nointerface.cpp @@ -136,7 +136,6 @@ Type objective_function::operator()(){ std::make_shared >(); rec->rzero = R0; rec->steep = h; - rec->log_sigma_recruit = logR_sd; /*the log_recruit_dev vector does not include a value for year == 0 and is of length nyears - 1 where the first position of the vector corresponds to the second year of the time series.*/ diff --git a/tests/testthat/_snaps/fimsfit.md b/tests/testthat/_snaps/fimsfit.md new file mode 100644 index 000000000..18b9763dc --- /dev/null +++ b/tests/testthat/_snaps/fimsfit.md @@ -0,0 +1,14 @@ +# FIMSFit() creates an object of class 'FIMSFit' + + Code + print(result) + Message + i FIMS model version: 0.3.0.0 + i Total run time was 10 seconds + i Number of parameters: total=1, fixed_effects=1, and random_effects=0 + i Maximum gradient= NA + i Negative log likelihood (NLL): + * Marginal NLL= + * Total NLL= + i Terminal SB= + diff --git a/tests/testthat/fixtures/integration_test_data.RData b/tests/testthat/fixtures/integration_test_data.RData index 80efb0c8e..e3bc026d3 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/simulate-integration-test-data.R b/tests/testthat/fixtures/simulate-integration-test-data.R deleted file mode 100644 index 719822f06..000000000 --- a/tests/testthat/fixtures/simulate-integration-test-data.R +++ /dev/null @@ -1,48 +0,0 @@ -# Install the operating model repo from GitHub -remotes::install_github( - repo = "Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison" -) - -working_dir <- getwd() - -maindir <- tempdir() - -# Save the initial OM input using ASSAMC package (sigmaR = 0.4) -model_input <- ASSAMC::save_initial_input() - -# Configure the input parameters for the simulation -sim_num <- 150 -sim_input <- ASSAMC::save_initial_input( - base_case = TRUE, - input_list = model_input, - maindir = maindir, - om_sim_num = sim_num, - keep_sim_num = sim_num, - figure_number = 1, - seed_num = 9924, - case_name = "sim_data" -) - -# Run OM and generate om_input, om_output, and em_input -# using function from the model comparison project -ASSAMC::run_om(input_list = sim_input) - -on.exit(unlink(maindir, recursive = TRUE), add = TRUE) - -setwd(working_dir) -on.exit(setwd(working_dir), add = TRUE) - -# Loop through each simulation to load the results from the corresponding -# .RData files and save them into one file -om_input_list <- om_output_list <- em_input_list <- - vector(mode = "list", length = sim_num) -for (i in 1:sim_num) { - load(file.path(maindir, "sim_data", "output", "OM", paste0("OM", i, ".RData"))) - om_input_list[[i]] <- om_input - om_output_list[[i]] <- om_output - em_input_list[[i]] <- em_input -} - -save(om_input_list, om_output_list, em_input_list, - file = test_path("fixtures", "integration_test_data.RData") -) diff --git a/tests/testthat/helper-integration-tests-setup.R b/tests/testthat/helper-integration-tests-setup.R index b5107bbb2..b64568b25 100644 --- a/tests/testthat/helper-integration-tests-setup.R +++ b/tests/testthat/helper-integration-tests-setup.R @@ -1,4 +1,4 @@ -#' Set Up and Run FIMS Model +#' Set Up and Run FIMS Model without using wrapper functions #' #' This function sets up and runs the FIMS for a given iteration. #' It configures the model with the OM inputs and outputs (see simulated data from @@ -35,165 +35,259 @@ #' fixed parameters. #' } #' @examples -#' results <- setup_and_run_FIMS( +#' results <- setup_and_run_FIMS_without_wrappers( #' iter_id = 1, #' om_input_list = om_input_list, #' om_output_list = om_output_list, #' em_input_list = em_input_list, #' estimation_mode = TRUE #' ) -setup_and_run_FIMS <- function(iter_id, - om_input_list, - om_output_list, - em_input_list, - estimation_mode = TRUE, - map = list()) { +setup_and_run_FIMS_without_wrappers <- function(iter_id, + om_input_list, + om_output_list, + em_input_list, + estimation_mode = TRUE, + map = list()) { # Load operating model data for the current iteration - om_input <- om_input_list[[iter_id]] - om_output <- om_output_list[[iter_id]] - em_input <- em_input_list[[iter_id]] + om_input <- om_input_list[[iter_id]] # Operating model input for the current iteration + om_output <- om_output_list[[iter_id]] # Operating model output for the current iteration + em_input <- em_input_list[[iter_id]] # Estimation model input for the current iteration # Clear any previous FIMS settings clear() - # Recruitment - # create new module in the recruitment class (specifically Beverton-Holt, - # when there are other options, this would be where the option would be chosen) - recruitment <- new(BevertonHoltRecruitment) - - # NOTE: in first set of parameters below (for recruitment), - # $is_random_effect (default is FALSE) and $estimated (default is FALSE) - # are defined even if they match the defaults in order to provide an example - # of how that is done. Other sections of the code below leave defaults in - # place as appropriate. - - # set up logR_sd - # logR_sd is NOT logged. It needs to enter the model logged b/c the exp() is - # taken before the likelihood calculation - recruitment$log_sigma_recruit$value <- log(om_input$logR_sd) - recruitment$log_sigma_recruit$is_random_effect <- FALSE - recruitment$log_sigma_recruit$estimated <- FALSE - # set up log_rzero (equilibrium recruitment) - recruitment$log_rzero$value <- log(om_input$R0) - recruitment$log_rzero$is_random_effect <- FALSE - recruitment$log_rzero$estimated <- TRUE - # set up logit_steep - recruitment$logit_steep$value <- -log(1.0 - om_input$h) + log(om_input$h - 0.2) - recruitment$logit_steep$is_random_effect <- FALSE - recruitment$logit_steep$estimated <- FALSE - # turn on estimation of deviations - recruitment$estimate_log_devs <- TRUE - # recruit deviations should enter the model in normal space. - # The log is taken in the likelihood calculations - # alternative setting: recruitment$log_devs <- rep(0, length(om_input$logR.resid)) - recruitment$log_devs <- om_input$logR.resid[-1] - - # Data - catch <- em_input$L.obs$fleet1 + # Extract fishing fleet landings data (observed) and initialize index module + catch <- em_input[["L.obs"]][["fleet1"]] # set fishing fleet catch data, need to set dimensions of data index # currently FIMS only has a fleet module that takes index for both survey index and fishery catch - fishing_fleet_index <- new(Index, length(catch)) + fishing_fleet_index <- methods::new(Index, om_input[["nyr"]]) fishing_fleet_index$index_data <- catch # set fishing fleet age comp data, need to set dimensions of age comps - fishing_fleet_age_comp <- new(AgeComp, length(catch), om_input$nages) - fishing_fleet_age_comp$age_comp_data <- c(t(em_input$L.age.obs$fleet1)) * em_input$n.L$fleet1 - - # repeat for surveys - survey_index <- em_input$surveyB.obs$survey1 - survey_fleet_index <- new(Index, length(survey_index)) - survey_fleet_index$index_data <- survey_index - survey_fleet_age_comp <- new(AgeComp, length(survey_index), om_input$nages) - survey_fleet_age_comp$age_comp_data <- c(t(em_input$survey.age.obs$survey1)) * em_input$n.survey$survey1 + # Here the new function initializes the object with length nyr*nages + fishing_fleet_age_comp <- methods::new(AgeComp, om_input[["nyr"]], om_input[["nages"]]) + # Here we fill in the values for the object with the observed age comps for fleet one + # we multiply these proportions by the sample size for likelihood weighting + fishing_fleet_age_comp$age_comp_data <- c(t(em_input[["L.age.obs"]][["fleet1"]])) * em_input[["n.L"]][["fleet1"]] - # Growth - ewaa_growth <- new(EWAAgrowth) - ewaa_growth$ages <- om_input$ages - ewaa_growth$weights <- om_input$W.mt - - # Maturity - maturity <- new(LogisticMaturity) - maturity$inflection_point$value <- om_input$A50.mat - maturity$inflection_point$is_random_effect <- FALSE - maturity$inflection_point$estimated <- FALSE - maturity$slope$value <- om_input$slope - maturity$slope$is_random_effect <- FALSE - maturity$slope$estimated <- FALSE + # set fishing fleet length comp data, need to set dimensions of length comps + fishing_fleet_length_comp <- methods::new(LengthComp, om_input[["nyr"]], om_input[["nlengths"]]) + fishing_fleet_length_comp$length_comp_data <- c(t(em_input[["L.length.obs"]][["fleet1"]])) * em_input[["n.L.lengthcomp"]][["fleet1"]] # Fleet # Create the fishing fleet - fishing_fleet_selectivity <- new(LogisticSelectivity) - fishing_fleet_selectivity$inflection_point$value <- om_input$sel_fleet$fleet1$A50.sel1 - fishing_fleet_selectivity$inflection_point$is_random_effect <- FALSE + fishing_fleet_selectivity <- methods::new(LogisticSelectivity) + fishing_fleet_selectivity$inflection_point[1]$value <- om_input[["sel_fleet"]][["fleet1"]][["A50.sel1"]] + fishing_fleet_selectivity$inflection_point[1]$is_random_effect <- FALSE # turn on estimation of inflection_point - fishing_fleet_selectivity$inflection_point$estimated <- TRUE - fishing_fleet_selectivity$slope$value <- om_input$sel_fleet$fleet1$slope.sel1 + fishing_fleet_selectivity$inflection_point[1]$estimated <- TRUE + fishing_fleet_selectivity$slope[1]$value <- om_input[["sel_fleet"]][["fleet1"]][["slope.sel1"]] # turn on estimation of slope - fishing_fleet_selectivity$slope$is_random_effect <- FALSE - fishing_fleet_selectivity$slope$estimated <- TRUE - - fishing_fleet <- new(Fleet) - fishing_fleet$nages <- om_input$nages - fishing_fleet$nyears <- om_input$nyr - fishing_fleet$log_Fmort <- log(om_output$f) - fishing_fleet$estimate_F <- TRUE - fishing_fleet$random_F <- FALSE - fishing_fleet$log_q <- log(1.0) + fishing_fleet_selectivity$slope[1]$is_random_effect <- FALSE + fishing_fleet_selectivity$slope[1]$estimated <- TRUE + + # Initialize the fishing fleet module + fishing_fleet <- methods::new(Fleet) + # Set number of years + fishing_fleet$nyears <- om_input[["nyr"]] + # Set number of age classes + fishing_fleet$nages <- om_input[["nages"]] + # Set number of length bins + fishing_fleet$nlengths <- om_input[["nlengths"]] + + fishing_fleet$log_Fmort$resize(om_input[["nyr"]]) + for (y in 1:om_input$nyr) { + # Log-transform OM fishing mortality + fishing_fleet$log_Fmort[y]$value <- log(om_output[["f"]][y]) + } + fishing_fleet$log_Fmort$set_all_estimable(TRUE) + fishing_fleet$log_q[1]$value <- log(1.0) fishing_fleet$estimate_q <- FALSE fishing_fleet$random_q <- FALSE - fishing_fleet$log_obs_error <- rep(log(sqrt(log(em_input$cv.L$fleet1^2 + 1))), om_input$nyr) - fishing_fleet$estimate_obs_error <- FALSE - # Modules are linked together using module IDs - # Each module has a get_id() function that returns the unique ID for that module - # Each fleet uses the module IDs to link up the correct module to the correct fleet - # Note: Likelihoods not yet set up as a stand-alone modules, so no get_id() - fishing_fleet$SetAgeCompLikelihood(1) - fishing_fleet$SetIndexLikelihood(1) fishing_fleet$SetSelectivity(fishing_fleet_selectivity$get_id()) fishing_fleet$SetObservedIndexData(fishing_fleet_index$get_id()) fishing_fleet$SetObservedAgeCompData(fishing_fleet_age_comp$get_id()) - + fishing_fleet$SetObservedLengthCompData(fishing_fleet_length_comp$get_id()) + + # Set up fishery index data using the lognormal + fishing_fleet_index_distribution <- methods::new(DlnormDistribution) + # lognormal observation error transformed on the log scale + fishing_fleet_index_distribution$log_sd$resize(om_input[["nyr"]]) + for (y in 1:om_input[["nyr"]]) { + # Compute lognormal SD from OM coefficient of variation (CV) + fishing_fleet_index_distribution$log_sd[y]$value <- log(sqrt(log(em_input[["cv.L"]][["fleet1"]]^2 + 1))) + } + fishing_fleet_index_distribution$log_sd$set_all_estimable(FALSE) + # Set Data using the IDs from the modules defined above + fishing_fleet_index_distribution$set_observed_data(fishing_fleet$GetObservedIndexDataID()) + fishing_fleet_index_distribution$set_distribution_links("data", fishing_fleet$log_expected_index$get_id()) + + # Set up fishery age composition data using the multinomial + fishing_fleet_agecomp_distribution <- methods::new(DmultinomDistribution) + fishing_fleet_agecomp_distribution$set_observed_data(fishing_fleet$GetObservedAgeCompDataID()) + fishing_fleet_agecomp_distribution$set_distribution_links("data", fishing_fleet$proportion_catch_numbers_at_age$get_id()) + + # Set up fishery length composition data using the multinomial + fishing_fleet_lengthcomp_distribution <- methods::new(DmultinomDistribution) + fishing_fleet_lengthcomp_distribution$set_observed_data(fishing_fleet$GetObservedLengthCompDataID()) + fishing_fleet_lengthcomp_distribution$set_distribution_links("data", fishing_fleet$proportion_catch_numbers_at_length$get_id()) + + # Set age-to-length conversion matrix + # TODO: If an age_to_length_conversion matrix is provided, the code below + # still executes. Consider adding a check in the Rcpp interface to ensure + # users provide a vector of inputs. + fishing_fleet$age_length_conversion_matrix <- methods::new( + ParameterVector, + c(t(em_input[["age_to_length_conversion"]])), + om_input[["nages"]] * om_input[["nlengths"]] + ) + # Turn off estimation for length-at-age + fishing_fleet$age_length_conversion_matrix$set_all_estimable(FALSE) + fishing_fleet$age_length_conversion_matrix$set_all_random(FALSE) + + # Repeat similar setup for the survey fleet (e.g., index, age comp, and length comp) + # This includes initializing logistic selectivity, observed data modules, and distribution links. + survey_index <- em_input[["surveyB.obs"]][["survey1"]] + survey_fleet_index <- methods::new(Index, om_input[["nyr"]]) + survey_fleet_index$index_data <- survey_index + survey_fleet_age_comp <- methods::new(AgeComp, om_input[["nyr"]], om_input[["nages"]]) + survey_fleet_age_comp$age_comp_data <- c(t(em_input[["survey.age.obs"]][["survey1"]])) * em_input[["n.survey"]][["survey1"]] + survey_lengthcomp <- em_input[["survey.length.obs"]][["survey1"]] + survey_fleet_length_comp <- methods::new(LengthComp, om_input[["nyr"]], om_input[["nlengths"]]) + survey_fleet_length_comp$length_comp_data <- c(t(survey_lengthcomp)) * em_input[["n.survey.lengthcomp"]][["survey1"]] + # Fleet # Create the survey fleet - survey_fleet_selectivity <- new(LogisticSelectivity) - survey_fleet_selectivity$inflection_point$value <- om_input$sel_survey$survey1$A50.sel1 - survey_fleet_selectivity$inflection_point$is_random_effect <- FALSE + survey_fleet_selectivity <- methods::new(LogisticSelectivity) + survey_fleet_selectivity$inflection_point[1]$value <- om_input[["sel_survey"]][["survey1"]][["A50.sel1"]] + survey_fleet_selectivity$inflection_point[1]$is_random_effect <- FALSE # turn on estimation of inflection_point - survey_fleet_selectivity$inflection_point$estimated <- TRUE - survey_fleet_selectivity$slope$value <- om_input$sel_survey$survey1$slope.sel1 - survey_fleet_selectivity$slope$is_random_effect <- FALSE + survey_fleet_selectivity$inflection_point[1]$estimated <- TRUE + survey_fleet_selectivity$slope[1]$value <- om_input[["sel_survey"]][["survey1"]][["slope.sel1"]] + survey_fleet_selectivity$slope[1]$is_random_effect <- FALSE # turn on estimation of slope - survey_fleet_selectivity$slope$estimated <- TRUE + survey_fleet_selectivity$slope[1]$estimated <- TRUE - survey_fleet <- new(Fleet) + survey_fleet <- methods::new(Fleet) survey_fleet$is_survey <- TRUE - survey_fleet$nages <- om_input$nages - survey_fleet$nyears <- om_input$nyr - survey_fleet$estimate_F <- FALSE - survey_fleet$random_F <- FALSE - survey_fleet$log_q <- log(om_output$survey_q$survey1) + survey_fleet$nages <- om_input[["nages"]] + survey_fleet$nyears <- om_input[["nyr"]] + survey_fleet$nlengths <- om_input[["nlengths"]] + survey_fleet$log_q[1]$value <- log(om_output[["survey_q"]][["survey1"]]) + survey_fleet$log_q[1]$estimated <- TRUE survey_fleet$estimate_q <- TRUE survey_fleet$random_q <- FALSE - survey_fleet$log_obs_error <- rep(log(sqrt(log(em_input$cv.survey$survey1^2 + 1))), om_input$nyr) - survey_fleet$estimate_obs_error <- FALSE - survey_fleet$SetAgeCompLikelihood(1) - survey_fleet$SetIndexLikelihood(1) survey_fleet$SetSelectivity(survey_fleet_selectivity$get_id()) survey_fleet$SetObservedIndexData(survey_fleet_index$get_id()) survey_fleet$SetObservedAgeCompData(survey_fleet_age_comp$get_id()) + survey_fleet$SetObservedLengthCompData(survey_fleet_length_comp$get_id()) + + # Set up survey index data using the lognormal + survey_fleet_index_distribution <- methods::new(DlnormDistribution) + # lognormal observation error transformed on the log scale + # sd = sqrt(log(cv^2 + 1)), sd is log transformed + survey_fleet_index_distribution$log_sd$resize(om_input[["nyr"]]) + for (y in 1:om_input$nyr) { + survey_fleet_index_distribution$log_sd[y]$value <- log(sqrt(log(em_input[["cv.survey"]][["survey1"]]^2 + 1))) + } + survey_fleet_index_distribution$log_sd$set_all_estimable(FALSE) + # Set Data using the IDs from the modules defined above + survey_fleet_index_distribution$set_observed_data(survey_fleet$GetObservedIndexDataID()) + survey_fleet_index_distribution$set_distribution_links("data", survey_fleet$log_expected_index$get_id()) + + # Age composition distribution + survey_fleet_agecomp_distribution <- methods::new(DmultinomDistribution) + survey_fleet_agecomp_distribution$set_observed_data(survey_fleet$GetObservedAgeCompDataID()) + survey_fleet_agecomp_distribution$set_distribution_links("data", survey_fleet$proportion_catch_numbers_at_age$get_id()) + + # Length composition distribution + survey_fleet_lengthcomp_distribution <- methods::new(DmultinomDistribution) + survey_fleet_lengthcomp_distribution$set_observed_data(survey_fleet$GetObservedLengthCompDataID()) + survey_fleet_lengthcomp_distribution$set_distribution_links("data", survey_fleet$proportion_catch_numbers_at_length$get_id()) # Set age to length conversion matrix + survey_fleet$age_length_conversion_matrix <- methods::new( + ParameterVector, + c(t(em_input[["age_to_length_conversion"]])), + om_input[["nages"]] * om_input[["nlengths"]] + ) + # Turn off estimation for length-at-age + survey_fleet$age_length_conversion_matrix$set_all_estimable(FALSE) + survey_fleet$age_length_conversion_matrix$set_all_random(FALSE) + + # Recruitment + # create new module in the recruitment class (specifically Beverton-Holt, + # when there are other options, this would be where the option would be chosen) + recruitment <- methods::new(BevertonHoltRecruitment) + + # NOTE: in first set of parameters below (for recruitment), + # $is_random_effect (default is FALSE) and $estimated (default is FALSE) + # are defined even if they match the defaults in order to provide an example + # of how that is done. Other sections of the code below leave defaults in + # place as appropriate. + + # set up log_rzero (equilibrium recruitment) + recruitment$log_rzero[1]$value <- log(om_input[["R0"]]) + recruitment$log_rzero[1]$is_random_effect <- FALSE + recruitment$log_rzero[1]$estimated <- TRUE + # set up logit_steep + recruitment$logit_steep[1]$value <- -log(1.0 - om_input[["h"]]) + log(om_input[["h"]] - 0.2) + recruitment$logit_steep[1]$is_random_effect <- FALSE + recruitment$logit_steep[1]$estimated <- FALSE + # turn on estimation of deviations + # recruit deviations should enter the model in normal space. + # The log is taken in the likelihood calculations + # alternative setting: recruitment$log_devs <- rep(0, length(om_input$logR.resid)) + recruitment$log_devs$resize(om_input[["nyr"]] - 1) + for (y in 1:(om_input[["nyr"]] - 1)) { + recruitment$log_devs[y]$value <- om_input[["logR.resid"]][y + 1] + } + recruitment_distribution <- methods::new(DnormDistribution) + # set up logR_sd using the normal log_sd parameter + # logR_sd is NOT logged. It needs to enter the model logged b/c the exp() is + # taken before the likelihood calculation + recruitment_distribution$log_sd <- methods::new(ParameterVector, 1) + recruitment_distribution$log_sd[1]$value <- log(om_input[["logR_sd"]]) + recruitment_distribution$log_sd[1]$estimated <- FALSE + recruitment_distribution$x$resize(om_input[["nyr"]] - 1) + recruitment_distribution$expected_values$resize(om_input[["nyr"]] - 1) + for (i in 1:(om_input[["nyr"]] - 1)) { + recruitment_distribution$x[i]$value <- 0 + recruitment_distribution$expected_values[i]$value <- 0 + } + recruitment_distribution$set_distribution_links("random_effects", recruitment$log_devs$get_id()) + recruitment$estimate_log_devs <- TRUE + + # Growth + ewaa_growth <- methods::new(EWAAgrowth) + ewaa_growth$ages <- om_input[["ages"]] + ewaa_growth$weights <- om_input[["W.mt"]] + + # Maturity + maturity <- methods::new(LogisticMaturity) + maturity$inflection_point[1]$value <- om_input[["A50.mat"]] + maturity$inflection_point[1]$is_random_effect <- FALSE + maturity$inflection_point[1]$estimated <- FALSE + maturity$slope[1]$value <- om_input[["slope.mat"]] + maturity$slope[1]$is_random_effect <- FALSE + maturity$slope[1]$estimated <- FALSE # Population - population <- new(Population) - population$log_M <- rep(log(om_input$M.age[1]), om_input$nyr * om_input$nages) - population$estimate_M <- FALSE - population$log_init_naa <- log(om_output$N.age[1, ]) - population$estimate_init_naa <- TRUE - population$nages <- om_input$nages - population$ages <- om_input$ages - population$nfleets <- sum(om_input$fleet_num, om_input$survey_num) + population <- methods::new(Population) + population$log_M$resize(om_input[["nyr"]] * om_input[["nages"]]) + for (i in 1:(om_input[["nyr"]] * om_input[["nages"]])) { + population$log_M[i]$value <- log(om_input[["M.age"]][1]) + } + population$log_M$set_all_estimable(FALSE) + population$log_init_naa$resize(om_input[["nages"]]) + for (i in 1:om_input$nages) { + population$log_init_naa[i]$value <- log(om_output[["N.age"]][1, i]) + } + population$log_init_naa$set_all_estimable(TRUE) + population$nages <- om_input[["nages"]] + population$ages <- om_input[["ages"]] + population$nfleets <- sum(om_input[["fleet_num"]], om_input[["survey_num"]]) population$nseasons <- 1 - population$nyears <- om_input$nyr - population$SetMaturity(maturity$get_id()) - population$SetGrowth(ewaa_growth$get_id()) + population$nyears <- om_input[["nyr"]] population$SetRecruitment(recruitment$get_id()) + population$SetGrowth(ewaa_growth$get_id()) + population$SetMaturity(maturity$get_id()) # Set-up TMB CreateTMBModel() @@ -207,13 +301,13 @@ setup_and_run_FIMS <- function(iter_id, # Optimization with nlminb opt <- NULL if (estimation_mode == TRUE) { - opt <- stats::nlminb(obj$par, obj$fn, obj$gr, + opt <- stats::nlminb(obj[["par"]], obj[["fn"]], obj[["gr"]], control = list(eval.max = 800, iter.max = 800) ) } # Call report using MLE parameter values, or # the initial values if optimization is skipped - report <- obj$report(obj$env$last.par.best) + report <- obj[["report"]](obj[["env"]][["last.par.best"]]) sdr <- TMB::sdreport(obj) sdr_report <- summary(sdr, "report") @@ -228,217 +322,144 @@ setup_and_run_FIMS <- function(iter_id, opt = opt, report = report, sdr_report = sdr_report, - sdr_fixed = sdr_fixed + sdr_fixed = sdr_fixed, + sdr = sdr )) } -#' Validate FIMS Model Output -#' -#' This function validates the output from the FIMS -#' against the known OM values. -#' It performs various checks to ensure that the estimates provided by the FIMS -#' are within acceptable tolerance compared to the operating model values. +#' Set Up and Run FIMS Model using wrapper functions #' -#' @param report A list containing the results of the TMB model report. This -#' includes the estimated recruitment numbers and other relevant metrics. -#' @param sdr A list containing the standard deviation report from the TMB model. -#' @param sdr_report A matrix containing the summary of the standard deviation report. -#' @param om_input A list containing the operating model inputs, such as years, -#' ages, and other parameters. -#' @param om_output A list containing the operating model outputs, including metrics -#' such as numbers at age, biomass, spawning biomass, fishing mortality, and survey indices. -#' @param em_input A list containing the estimation model inputs, including observed -#' catches, survey indices, and other relevant data. +#' This function sets up and runs the FIMS for a given iteration. +#' It configures the model with the OM inputs and outputs (see simulated data from +#' tests/testthat/fixtures/simulate-integration-test-data.R), +#' and runs the optimization process. +#' It then generates and returns the results including parameter estimates, model +#' reports, and standard deviation reports. #' -#' @return None. The function uses `testthat` functions to perform validations. -#' It ensures that the output is within the expected range of error based on -#' standard deviations provided. +#' @param iter_id An integer specifying the iteration ID to use for loading +#' the OM data. +#' @param om_input_list A list of OM inputs, where each element +#' corresponds to a different iteration. +#' @param om_output_list A list of OM outputs, where each element +#' corresponds to a different iteration. +#' @param em_input_list A list of EM inputs, where each element +#' corresponds to a different iteration. +#' @param estimation_mode A logical value indicating whether to perform +#' optimization (`TRUE`) or skip it (`FALSE`). If `TRUE`, the model parameters +#' will be optimized using `nlminb`. If `FALSE`, the initial values will be used +#' for the report. +#' @param map A list used to specify mapping for the `MakeADFun` function from +#' the TMB package. #' +#' @return A list containing the following elements: +#' \itemize{ +#' \item{parameters:} A list of parameters for the TMB model. +#' \item{obj:} The TMB model object created by `TMB::MakeADFun`. +#' \item{opt:} The result of the optimization process, if `estimation_mode` +#' is `TRUE`. `NULL` if `estimation_mode` is `FALSE`. +#' \item{report:} The model report obtained from the TMB model. +#' \item{sdr_report:} Summary of the standard deviation report for the +#' model parameters. +#' \item{sdr_fixed:} Summary of the standard deviation report for the +#' fixed parameters. +#' } #' @examples -#' # Assume `result` is a list of outputs obtained from running `setup_and_run_FIMS()`. -#' # The `result` list contains components such as `report`, `sdr_report`, and `obj`. -#' -#' validate_fims( -#' report = result$report, -#' sdr = TMB::sdreport(result$obj), -#' sdr_report = result$sdr_report, -#' om_input = om_input_list[[1]], -#' om_output = om_output_list[[1]], -#' em_input = em_input_list[[1]] +#' results <- setup_and_run_FIMS_with_wrappers( +#' iter_id = 1, +#' om_input_list = om_input_list, +#' om_output_list = om_output_list, +#' em_input_list = em_input_list, +#' estimation_mode = TRUE #' ) -validate_fims <- function( - report, - sdr, - sdr_report, - om_input, - om_output, - em_input) { - # Numbers at age - # Estimates and SE for NAA - sdr_naa <- sdr_report[which(rownames(sdr_report) == "NAA"), ] - naa_are <- rep(0, length(c(t(om_output$N.age)))) - for (i in 1:length(c(t(om_output$N.age)))) { - naa_are[i] <- abs(sdr_naa[i, 1] - c(t(om_output$N.age))[i]) - } - # Expect 95% of absolute error to be within 2*SE of NAA - expect_lte( - sum(naa_are > qnorm(.975) * sdr_naa[1:length(c(t(om_output$N.age))), 2]), - 0.05 * length(c(t(om_output$N.age))) - ) - - # Biomass - sdr_biomass <- sdr_report[which(rownames(sdr_report) == "Biomass"), ] - biomass_are <- rep(0, length(om_output$biomass.mt)) - for (i in 1:length(om_output$biomass.mt)) { - biomass_are[i] <- abs(sdr_biomass[i, 1] - om_output$biomass.mt[i]) # / om_output$biomass.mt[i] - # expect_lte(biomass_are[i], 0.15) - } - expect_lte( - sum(biomass_are > qnorm(.975) * sdr_biomass[1:length(om_output$biomass.mt), 2]), - 0.05 * length(om_output$biomass.mt) - ) - - # Spawning biomass - sdr_sb <- sdr_report[which(rownames(sdr_report) == "SSB"), ] - sb_are <- rep(0, length(om_output$SSB)) - for (i in 1:length(om_output$SSB)) { - sb_are[i] <- abs(sdr_sb[i, 1] - om_output$SSB[i]) # / om_output$SSB[i] - # expect_lte(sb_are[i], 0.15) - } - expect_lte( - sum(sb_are > qnorm(.975) * sdr_sb[1:length(om_output$SSB), 2]), - 0.05 * length(om_output$SSB) - ) - - # Recruitment - fims_naa <- matrix(report$naa[[1]][1:(om_input$nyr * om_input$nages)], - nrow = om_input$nyr, byrow = TRUE - ) - sdr_naa1_vec <- sdr_report[which(rownames(sdr_report) == "NAA"), 2] - sdr_naa1 <- sdr_naa1_vec[seq(1, om_input$nyr * om_input$nages, by = om_input$nages)] - fims_naa1_are <- rep(0, om_input$nyr) - for (i in 1:om_input$nyr) { - fims_naa1_are[i] <- abs(fims_naa[i, 1] - om_output$N.age[i, 1]) # / - # om_output$N.age[i, 1] - # expect_lte(fims_naa1_are[i], 0.25) - } - expect_lte( - sum(fims_naa1_are > qnorm(.975) * sdr_naa1[1:length(om_output$SSB)]), - 0.05 * length(om_output$SSB) - ) - - expect_equal( - fims_naa[, 1], - report$recruitment[[1]][1:om_input$nyr] - ) - - # recruitment log deviations - # the initial value of om_input$logR.resid is dropped from the model - sdr_rdev <- sdr_report[which(rownames(sdr_report) == "LogRecDev"), ] - rdev_are <- rep(0, length(om_input$logR.resid) - 1) +setup_and_run_FIMS_with_wrappers <- function(iter_id, + om_input_list, + om_output_list, + em_input_list, + estimation_mode = TRUE, + map = list()) { + # Load operating model data for the current iteration + om_input <- om_input_list[[iter_id]] + om_output <- om_output_list[[iter_id]] + em_input <- em_input_list[[iter_id]] - for (i in 1:(length(report$log_recruit_dev[[1]]) - 1)) { - rdev_are[i] <- abs(report$log_recruit_dev[[1]][i] - om_input$logR.resid[i + 1]) # / - # exp(om_input$logR.resid[i]) - # expect_lte(rdev_are[i], 1) # 1 - } - expect_lte( - sum(rdev_are > qnorm(.975) * sdr_rdev[1:length(om_input$logR.resid) - 1, 2]), - 0.05 * length(om_input$logR.resid) - ) + # Clear any previous FIMS settings + clear() - # F (needs to be updated when std.error is available) - sdr_F <- sdr_report[which(rownames(sdr_report) == "FMort"), ] - f_are <- rep(0, length(om_output$f)) - for (i in 1:length(om_output$f)) { - f_are[i] <- abs(sdr_F[i, 1] - om_output$f[i]) - } - # Expect 95% of absolute error to be within 2*SE of Fmort - expect_lte( - sum(f_are > qnorm(.975) * sdr_F[1:length(om_output$f), 2]), - 0.05 * length(om_output$f) + data <- FIMS::FIMSFrame(data1) + + # Set up default parameters + fleets <- list( + fleet1 = list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) + ), + survey1 = list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) + ) ) - # Expected fishery catch and survey index - fims_index <- sdr_report[which(rownames(sdr_report) == "ExpectedIndex"), ] - fims_catch <- fims_index[1:om_input$nyr, ] - fims_survey <- fims_index[(om_input$nyr + 1):(om_input$nyr * 2), ] - - # Expected fishery catch - om_output - catch_are <- rep(0, length(om_output$L.mt$fleet1)) - for (i in 1:length(om_output$L.mt$fleet1)) { - catch_are[i] <- abs(fims_catch[i, 1] - om_output$L.mt$fleet1[i]) - } - # Expect 95% of absolute error to be within 2*SE of fishery catch - expect_lte( - sum(catch_are > qnorm(.975) * fims_catch[, 2]), - 0.05 * length(om_output$L.mt$fleet1) - ) + default_parameters <- data |> + create_default_parameters( + fleets = fleets, + recruitment = list( + form = "BevertonHoltRecruitment", + process_distribution = c(log_devs = "DnormDistribution") + ), + growth = list(form = "EWAAgrowth"), + maturity = list(form = "LogisticMaturity") + ) - # Expected fishery catch - em_input - catch_are <- rep(0, length(em_input$L.obs$fleet1)) - for (i in 1:length(em_input$L.obs$fleet1)) { - catch_are[i] <- abs(fims_catch[i, 1] - em_input$L.obs$fleet1[i]) - } - # Expect 95% of absolute error to be within 2*SE of fishery catch - expect_lte( - sum(catch_are > qnorm(.975) * fims_catch[, 2]), - 0.05 * length(em_input$L.obs$fleet1) + # Modify parameters + modified_parameters <- list( + fleet1 = list( + LogisticSelectivity.inflection_point.value = om_input[["sel_fleet"]][["fleet1"]][["A50.sel1"]], + LogisticSelectivity.slope.value = om_input[["sel_fleet"]][["fleet1"]][["slope.sel1"]], + Fleet.log_Fmort.value = log(om_output[["f"]]) + ), + survey1 = list( + LogisticSelectivity.inflection_point.value = om_input[["sel_survey"]][["survey1"]][["A50.sel1"]], + LogisticSelectivity.slope.value = om_input[["sel_survey"]][["survey1"]][["slope.sel1"]], + Fleet.log_q.value = log(om_output[["survey_q"]][["survey1"]]) + ), + recruitment = list( + BevertonHoltRecruitment.log_rzero.value = log(om_input[["R0"]]), + BevertonHoltRecruitment.log_devs.value = om_input[["logR.resid"]][-1], + BevertonHoltRecruitment.log_devs.estimated = FALSE, + DnormDistribution.log_sd.value = om_input[["logR_sd"]] + ), + maturity = list( + LogisticMaturity.inflection_point.value = om_input[["A50.mat"]], + LogisticMaturity.inflection_point.estimated = FALSE, + LogisticMaturity.slope.value = om_input[["slope.mat"]], + LogisticMaturity.slope.estimated = FALSE + ), + population = list( + Population.log_init_naa.value = log(om_output[["N.age"]][1, ]) + ) ) + parameters <- default_parameters |> + update_parameters( + modified_parameters = modified_parameters + ) - # Expected fishery catch number at age - sdr_cnaa <- sdr_report[which(rownames(sdr_report) == "CNAA"), ] - cnaa_are <- rep(0, length(c(t(om_output$L.age$fleet1)))) - for (i in 1:length(c(t(om_output$L.age$fleet1)))) { - cnaa_are[i] <- abs(sdr_cnaa[i, 1] - c(t(om_output$L.age$fleet1))[i]) - } - # Expect 95% of absolute error to be within 2*SE of CNAA - expect_lte( - sum(cnaa_are > qnorm(.975) * sdr_cnaa[, 2]), - 0.05 * length(c(t(om_output$L.age$fleet1))) - ) - - # Expected survey index - om_output - index_are <- rep(0, length(om_output$survey_index_biomass$survey1)) - for (i in 1:length(om_output$survey_index_biomass$survey1)) { - index_are[i] <- abs(fims_survey[i, 1] - om_output$survey_index_biomass$survey1[i]) - } - # Expect 95% of absolute error to be within 2*SE of survey index - expect_lte( - sum(index_are > qnorm(.975) * fims_survey[, 2]), - 0.05 * length(om_output$survey_index_biomass$survey1) + parameter_list <- initialize_fims( + parameters = parameters, + data = data ) - # Expected survey index - em_input - index_are <- rep(0, length(em_input$surveyB.obs$survey1)) - for (i in 1:length(em_input$surveyB.obs$survey1)) { - index_are[i] <- abs(fims_survey[i, 1] - em_input$surveyB.obs$survey1[i]) - } - # # Expect 95% of absolute error to be within 2*SE of survey index - # expect_lte( - # sum(index_are > qnorm(.975) * fims_survey[, 2]), - # 0.05 * length(em_input$surveyB.obs$survey1) - # ) - - for (i in 1:length(em_input$surveyB.obs$survey1)) { - expect_lte(abs(fims_survey[i, 1] - em_input$surveyB.obs$survey1[i]) / - em_input$surveyB.obs$survey1[i], 0.25) - } + fit <- fit_fims(parameter_list, optimize = estimation_mode) - # Expected survey number at age - # for (i in 1:length(c(t(om_output$survey_age_comp$survey1)))){ - # expect_lte(abs(report$cnaa[i,2] - c(t(om_output$survey_age_comp$survey1))[i])/ - # c(t(om_output$survey_age_comp$survey1))[i], 0.001) - # } - - # Expected catch number at age in proportion - # fims_cnaa <- matrix(report$cnaa[1:(om_input$nyr*om_input$nages), 2], - # nrow = om_input$nyr, byrow = TRUE) - # fims_cnaa_proportion <- fims_cnaa/rowSums(fims_cnaa) - # - # for (i in 1:length(c(t(em_input$survey.age.obs)))){ - # expect_lte(abs(c(t(fims_cnaa_proportion))[i] - c(t(em_input$L.age.obs$fleet1))[i])/ - # c(t(em_input$L.age.obs$fleet1))[i], 0.15) - # } + clear() + # Return the results as a list + return(fit) } diff --git a/tests/testthat/helper-integration-tests-validation.R b/tests/testthat/helper-integration-tests-validation.R new file mode 100644 index 000000000..8edba7cd6 --- /dev/null +++ b/tests/testthat/helper-integration-tests-validation.R @@ -0,0 +1,384 @@ +#' Validate FIMS Model Output +#' +#' This function validates the output from the FIMS +#' against the known OM values. +#' It performs various checks to ensure that the estimates provided by the FIMS +#' are within acceptable tolerance compared to the operating model values. +#' +#' @param report A list containing the results of the TMB model report. This +#' includes the estimated recruitment numbers and other relevant metrics. +#' @param sdr A list containing the standard deviation report from the TMB model. +#' @param sdr_report A matrix containing the summary of the standard deviation report. +#' @param om_input A list containing the operating model inputs, such as years, +#' ages, and other parameters. +#' @param om_output A list containing the operating model outputs, including metrics +#' such as numbers at age, biomass, spawning biomass, fishing mortality, and survey indices. +#' @param em_input A list containing the estimation model inputs, including observed +#' catches, survey indices, and other relevant data. +#' @param use_fimsfit Logical; if `TRUE`, validates using `fit_fims()` results. +#' +#' @return None. The function uses `testthat` functions to perform validations. +#' It ensures that the output is within the expected range of error based on +#' standard deviations provided. +#' +#' @examples +#' # Assume `result` is a list of outputs obtained from running `setup_and_run_FIMS()`. +#' # The `result` list contains components such as `report`, `sdr_report`, and `obj`. +#' +#' validate_fims( +#' report = result$report, +#' sdr = TMB::sdreport(result$obj), +#' sdr_report = result$sdr_report, +#' om_input = om_input_list[[1]], +#' om_output = om_output_list[[1]], +#' em_input = em_input_list[[1]], +#' use_fimsfit = FALSE +#' ) +validate_fims <- function( + report, + sdr, + sdr_report, + om_input, + om_output, + em_input, + use_fimsfit = FALSE) { + if (use_fimsfit == TRUE) { + # Numbers at age + # Estimates and SE for NAA + sdr_naa <- sdr_report[which(sdr_report[["name"]] == "NAA"), c("value", "se")] + naa_are <- rep(0, length(c(t(om_output[["N.age"]])))) + for (i in 1:length(c(t(om_output[["N.age"]])))) { + naa_are[i] <- abs(sdr_naa[i, "value"] - c(t(om_output[["N.age"]]))[i]) + } + # Expect 95% of absolute error to be within 2*SE of NAA + expect_lte( + sum(unlist(naa_are) > qnorm(.975) * sdr_naa[1:length(c(t(om_output[["N.age"]]))), "se"]), + 0.05 * length(c(t(om_output[["N.age"]]))) + ) + + # Biomass + sdr_biomass <- sdr_report[which(sdr_report[["name"]] == "Biomass"), c("value", "se")] + biomass_are <- rep(0, length(om_output[["biomass.mt"]])) + for (i in 1:length(om_output[["biomass.mt"]])) { + biomass_are[i] <- abs(sdr_biomass[i, "value"] - om_output[["biomass.mt"]][i]) # / om_output[["biomass.mt"]][i] + # expect_lte(biomass_are[i], 0.15) + } + expect_lte( + sum(unlist(biomass_are) > qnorm(.975) * sdr_biomass[1:length(om_output[["biomass.mt"]]), "se"]), + 0.05 * length(om_output[["biomass.mt"]]) + ) + + # Spawning biomass + sdr_sb <- sdr_report[which(sdr_report[["name"]] == "SSB"), c("value", "se")] + sb_are <- rep(0, length(om_output[["SSB"]])) + for (i in 1:length(om_output[["SSB"]])) { + sb_are[i] <- abs(sdr_sb[i, "value"] - om_output[["SSB"]][i]) # / om_output[["SSB"]][i] + # expect_lte(sb_are[i], 0.15) + } + expect_lte( + sum(unlist(sb_are) > qnorm(.975) * sdr_sb[1:length(om_output[["SSB"]]), "se"]), + 0.05 * length(om_output[["SSB"]]) + ) + + # Recruitment + fims_naa <- matrix(report[["naa"]][[1]][1:(om_input[["nyr"]] * om_input[["nages"]])], + nrow = om_input[["nyr"]], byrow = TRUE + ) + sdr_naa1_vec <- sdr_report[which(sdr_report[["name"]] == "NAA"), "se"] + sdr_naa1 <- sdr_naa1_vec[seq(1, om_input[["nyr"]] * om_input[["nages"]], by = om_input[["nages"]]), "se"] + fims_naa1_are <- rep(0, om_input[["nyr"]]) + for (i in 1:om_input[["nyr"]]) { + fims_naa1_are[i] <- abs(fims_naa[i, 1] - om_output[["N.age"]][i, 1]) # / + # om_output[["N.age"]][i, 1] + # expect_lte(fims_naa1_are[i], 0.25) + } + expect_lte( + sum(fims_naa1_are > qnorm(.975) * sdr_naa1[1:length(om_output[["SSB"]]), "se"]), + 0.05 * length(om_output[["SSB"]]) + ) + + expect_equal( + fims_naa[, 1], + report[["recruitment"]][[1]][1:om_input[["nyr"]]] + ) + + # recruitment log deviations + # the initial value of om_input[["logR.resid"]] is dropped from the model + sdr_rdev <- sdr_report[which(sdr_report[["name"]] == "LogRecDev"), c("value", "se")] + rdev_are <- rep(0, length(om_input[["logR.resid"]]) - 1) + + for (i in 1:(length(report[["log_recruit_dev"]][[1]]) - 1)) { + rdev_are[i] <- abs(report[["log_recruit_dev"]][[1]][i] - om_input[["logR.resid"]][i + 1]) # / + # exp(om_input[["logR.resid"]][i]) + # expect_lte(rdev_are[i], 1) # 1 + } + expect_lte( + sum(rdev_are > qnorm(.975) * sdr_rdev[1:length(om_input[["logR.resid"]]) - 1, 2]), + 0.05 * length(om_input[["logR.resid"]]) + ) + + # F (needs to be updated when std.error is available) + sdr_F <- sdr_report[which(sdr_report[["name"]] == "FMort"), c("value", "se")] + f_are <- rep(0, length(om_output[["f"]])) + for (i in 1:length(om_output[["f"]])) { + f_are[i] <- abs(sdr_F[i, 1] - om_output[["f"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of Fmort + expect_lte( + sum(unlist(f_are) > qnorm(.975) * sdr_F[1:length(om_output[["f"]]), 2]), + 0.05 * length(om_output[["f"]]) + ) + + # Expected fishery catch and survey index + fims_index <- sdr_report[which(sdr_report[["name"]] == "ExpectedIndex"), c("value", "se")] + fims_catch <- fims_index[1:om_input[["nyr"]], ] + fims_survey <- fims_index[(om_input[["nyr"]] + 1):(om_input[["nyr"]] * 2), ] + + # Expected fishery catch - om_output + catch_are <- rep(0, length(om_output[["L.mt"]][["fleet1"]])) + for (i in 1:length(om_output[["L.mt"]][["fleet1"]])) { + catch_are[i] <- abs(fims_catch[i, 1] - om_output[["L.mt"]][["fleet1"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of fishery catch + expect_lte( + sum(unlist(catch_are) > qnorm(.975) * fims_catch[, 2]), + 0.05 * length(om_output[["L.mt"]][["fleet1"]]) + ) + + # Expected fishery catch - em_input + catch_are <- rep(0, length(em_input[["L.obs"]][["fleet1"]])) + for (i in 1:length(em_input[["L.obs"]][["fleet1"]])) { + catch_are[i] <- abs(fims_catch[i, 1] - em_input[["L.obs"]][["fleet1"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of fishery catch + expect_lte( + sum(unlist(catch_are) > qnorm(.975) * fims_catch[, 2]), + 0.05 * length(em_input[["L.obs"]][["fleet1"]]) + ) + + + # Expected fishery catch number at age + sdr_cnaa <- sdr_report[which(sdr_report[["name"]] == "CNAA"), c("value", "se")] + cnaa_are <- rep(0, length(c(t(om_output[["L.age"]][["fleet1"]])))) + for (i in 1:length(c(t(om_output[["L.age"]][["fleet1"]])))) { + cnaa_are[i] <- abs(sdr_cnaa[i, 1] - c(t(om_output[["L.age"]][["fleet1"]]))[i]) + } + # Expect 95% of absolute error to be within 2*SE of CNAA + expect_lte( + sum(unlist(cnaa_are) > qnorm(.975) * sdr_cnaa[, 2]), + 0.05 * length(c(t(om_output[["L.age"]][["fleet1"]]))) + ) + + # Expected survey index - om_output + index_are <- rep(0, length(om_output[["survey_index_biomass"]][["survey1"]])) + for (i in 1:length(om_output[["survey_index_biomass"]][["survey1"]])) { + index_are[i] <- abs(fims_survey[i, 1] - om_output[["survey_index_biomass"]][["survey1"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of survey index + expect_lte( + sum(unlist(index_are) > qnorm(.975) * fims_survey[, 2]), + 0.05 * length(om_output[["survey_index_biomass"]][["survey1"]]) + ) + + # Expected survey index - em_input + index_are <- rep(0, length(em_input[["surveyB.obs"]][["survey1"]])) + for (i in 1:length(em_input[["surveyB.obs"]][["survey1"]])) { + index_are[i] <- abs(fims_survey[i, 1] - em_input[["surveyB.obs"]][["survey1"]][i]) + } + # # Expect 95% of absolute error to be within 2*SE of survey index + # expect_lte( + # sum(index_are > qnorm(.975) * fims_survey[, 2]), + # 0.05 * length(em_input[["surveyB.obs"]][["survey1"]]) + # ) + + for (i in 1:length(em_input[["surveyB.obs"]][["survey1"]])) { + expect_lte(abs(fims_survey[i, 1] - em_input[["surveyB.obs"]][["survey1"]][i]) / + em_input[["surveyB.obs"]][["survey1"]][i], 0.25) + } + + # Expected survey number at age + # for (i in 1:length(c(t(om_output[["survey_age_comp"]][["survey1"]])))){ + # expect_lte(abs(report[["cnaa"]][i,2] - c(t(om_output[["survey_age_comp"]][["survey1"]]))[i])/ + # c(t(om_output[["survey_age_comp"]][["survey1"]]))[i], 0.001) + # } + + # Expected catch number at age in proportion + # fims_cnaa <- matrix(report[["cnaa"]][1:(om_input[["nyr"]]*om_input[["nages"]]), 2], + # nrow = om_input[["nyr"]], byrow = TRUE) + # fims_cnaa_proportion <- fims_cnaa/rowSums(fims_cnaa) + # + # for (i in 1:length(c(t(em_input[["survey.age.obs"]])))){ + # expect_lte(abs(c(t(fims_cnaa_proportion))[i] - c(t(em_input[["L.age.obs"]][["fleet1"]]))[i])/ + # c(t(em_input[["L.age.obs"]][["fleet1"]]))[i], 0.15) + # } + } else { + # Numbers at age + # Estimates and SE for NAA + sdr_naa <- sdr_report[which(rownames(sdr_report) == "NAA"), ] + naa_are <- rep(0, length(c(t(om_output[["N.age"]])))) + for (i in 1:length(c(t(om_output[["N.age"]])))) { + naa_are[i] <- abs(sdr_naa[i, 1] - c(t(om_output[["N.age"]]))[i]) + } + # Expect 95% of absolute error to be within 2*SE of NAA + expect_lte( + sum(naa_are > qnorm(.975) * sdr_naa[1:length(c(t(om_output[["N.age"]]))), 2]), + 0.05 * length(c(t(om_output[["N.age"]]))) + ) + + # Biomass + sdr_biomass <- sdr_report[which(rownames(sdr_report) == "Biomass"), ] + biomass_are <- rep(0, length(om_output[["biomass.mt"]])) + for (i in 1:length(om_output[["biomass.mt"]])) { + biomass_are[i] <- abs(sdr_biomass[i, 1] - om_output[["biomass.mt"]][i]) # / om_output[["biomass.mt"]][i] + # expect_lte(biomass_are[i], 0.15) + } + expect_lte( + sum(biomass_are > qnorm(.975) * sdr_biomass[1:length(om_output[["biomass.mt"]]), 2]), + 0.05 * length(om_output[["biomass.mt"]]) + ) + + # Spawning biomass + sdr_sb <- sdr_report[which(rownames(sdr_report) == "SSB"), ] + sb_are <- rep(0, length(om_output[["SSB"]])) + for (i in 1:length(om_output[["SSB"]])) { + sb_are[i] <- abs(sdr_sb[i, 1] - om_output[["SSB"]][i]) # / om_output[["SSB"]][i] + # expect_lte(sb_are[i], 0.15) + } + expect_lte( + sum(sb_are > qnorm(.975) * sdr_sb[1:length(om_output[["SSB"]]), 2]), + 0.05 * length(om_output[["SSB"]]) + ) + + # Recruitment + fims_naa <- matrix(report[["naa"]][[1]][1:(om_input[["nyr"]] * om_input[["nages"]])], + nrow = om_input[["nyr"]], byrow = TRUE + ) + sdr_naa1_vec <- sdr_report[which(rownames(sdr_report) == "NAA"), 2] + sdr_naa1 <- sdr_naa1_vec[seq(1, om_input[["nyr"]] * om_input[["nages"]], by = om_input[["nages"]])] + fims_naa1_are <- rep(0, om_input[["nyr"]]) + for (i in 1:om_input[["nyr"]]) { + fims_naa1_are[i] <- abs(fims_naa[i, 1] - om_output[["N.age"]][i, 1]) # / + # om_output[["N.age"]][i, 1] + # expect_lte(fims_naa1_are[i], 0.25) + } + expect_lte( + sum(fims_naa1_are > qnorm(.975) * sdr_naa1[1:length(om_output[["SSB"]])]), + 0.05 * length(om_output[["SSB"]]) + ) + + expect_equal( + fims_naa[, 1], + report[["recruitment"]][[1]][1:om_input[["nyr"]]] + ) + + # recruitment log deviations + # the initial value of om_input[["logR.resid"]] is dropped from the model + sdr_rdev <- sdr_report[which(rownames(sdr_report) == "LogRecDev"), ] + rdev_are <- rep(0, length(om_input[["logR.resid"]]) - 1) + + for (i in 1:(length(report[["log_recruit_dev"]][[1]]) - 1)) { + rdev_are[i] <- abs(report[["log_recruit_dev"]][[1]][i] - om_input[["logR.resid"]][i + 1]) # / + # exp(om_input[["logR.resid"]][i]) + # expect_lte(rdev_are[i], 1) # 1 + } + expect_lte( + sum(rdev_are > qnorm(.975) * sdr_rdev[1:length(om_input[["logR.resid"]]) - 1, 2]), + 0.05 * length(om_input[["logR.resid"]]) + ) + + # F (needs to be updated when std.error is available) + sdr_F <- sdr_report[which(rownames(sdr_report) == "FMort"), ] + f_are <- rep(0, length(om_output[["f"]])) + for (i in 1:length(om_output[["f"]])) { + f_are[i] <- abs(sdr_F[i, 1] - om_output[["f"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of Fmort + expect_lte( + sum(f_are > qnorm(.975) * sdr_F[1:length(om_output[["f"]]), 2]), + 0.05 * length(om_output[["f"]]) + ) + + # Expected fishery catch and survey index + fims_index <- sdr_report[which(rownames(sdr_report) == "ExpectedIndex"), ] + fims_catch <- fims_index[1:om_input[["nyr"]], ] + fims_survey <- fims_index[(om_input[["nyr"]] + 1):(om_input[["nyr"]] * 2), ] + + # Expected fishery catch - om_output + catch_are <- rep(0, length(om_output[["L.mt"]][["fleet1"]])) + for (i in 1:length(om_output[["L.mt"]][["fleet1"]])) { + catch_are[i] <- abs(fims_catch[i, 1] - om_output[["L.mt"]][["fleet1"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of fishery catch + expect_lte( + sum(catch_are > qnorm(.975) * fims_catch[, 2]), + 0.05 * length(om_output[["L.mt"]][["fleet1"]]) + ) + + # Expected fishery catch - em_input + catch_are <- rep(0, length(em_input[["L.obs"]][["fleet1"]])) + for (i in 1:length(em_input[["L.obs"]][["fleet1"]])) { + catch_are[i] <- abs(fims_catch[i, 1] - em_input[["L.obs"]][["fleet1"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of fishery catch + expect_lte( + sum(catch_are > qnorm(.975) * fims_catch[, 2]), + 0.05 * length(em_input[["L.obs"]][["fleet1"]]) + ) + + + # Expected fishery catch number at age + sdr_cnaa <- sdr_report[which(rownames(sdr_report) == "CNAA"), ] + cnaa_are <- rep(0, length(c(t(om_output[["L.age"]][["fleet1"]])))) + for (i in 1:length(c(t(om_output[["L.age"]][["fleet1"]])))) { + cnaa_are[i] <- abs(sdr_cnaa[i, 1] - c(t(om_output[["L.age"]][["fleet1"]]))[i]) + } + # Expect 95% of absolute error to be within 2*SE of CNAA + expect_lte( + sum(cnaa_are > qnorm(.975) * sdr_cnaa[, 2]), + 0.05 * length(c(t(om_output[["L.age"]][["fleet1"]]))) + ) + + # Expected survey index - om_output + index_are <- rep(0, length(om_output[["survey_index_biomass"]][["survey1"]])) + for (i in 1:length(om_output[["survey_index_biomass"]][["survey1"]])) { + index_are[i] <- abs(fims_survey[i, 1] - om_output[["survey_index_biomass"]][["survey1"]][i]) + } + # Expect 95% of absolute error to be within 2*SE of survey index + expect_lte( + sum(index_are > qnorm(.975) * fims_survey[, 2]), + 0.05 * length(om_output[["survey_index_biomass"]][["survey1"]]) + ) + + # Expected survey index - em_input + index_are <- rep(0, length(em_input[["surveyB.obs"]][["survey1"]])) + for (i in 1:length(em_input[["surveyB.obs"]][["survey1"]])) { + index_are[i] <- abs(fims_survey[i, 1] - em_input[["surveyB.obs"]][["survey1"]][i]) + } + # # Expect 95% of absolute error to be within 2*SE of survey index + # expect_lte( + # sum(index_are > qnorm(.975) * fims_survey[, 2]), + # 0.05 * length(em_input[["surveyB.obs"]][["survey1"]]) + # ) + + for (i in 1:length(em_input[["surveyB.obs"]][["survey1"]])) { + expect_lte(abs(fims_survey[i, 1] - em_input[["surveyB.obs"]][["survey1"]][i]) / + em_input[["surveyB.obs"]][["survey1"]][i], 0.25) + } + + # Expected survey number at age + # for (i in 1:length(c(t(om_output[["survey_age_comp"]][["survey1"]])))){ + # expect_lte(abs(report[["cnaa"]][i,2] - c(t(om_output[["survey_age_comp"]][["survey1"]]))[i])/ + # c(t(om_output[["survey_age_comp"]][["survey1"]]))[i], 0.001) + # } + + # Expected catch number at age in proportion + # fims_cnaa <- matrix(report[["cnaa"]][1:(om_input[["nyr"]]*om_input[["nages"]]), 2], + # nrow = om_input[["nyr"]], byrow = TRUE) + # fims_cnaa_proportion <- fims_cnaa/rowSums(fims_cnaa) + # + # for (i in 1:length(c(t(em_input[["survey.age.obs"]])))){ + # expect_lte(abs(c(t(fims_cnaa_proportion))[i] - c(t(em_input[["L.age.obs"]][["fleet1"]]))[i])/ + # c(t(em_input[["L.age.obs"]][["fleet1"]]))[i], 0.15) + # } + } +} diff --git a/tests/testthat/test-create_default_parameters.R b/tests/testthat/test-create_default_parameters.R new file mode 100644 index 000000000..162816635 --- /dev/null +++ b/tests/testthat/test-create_default_parameters.R @@ -0,0 +1,49 @@ +data("data1") +data <- FIMSFrame(data1) + +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution" + ) +) + +fleets = list(fleet1 = fleet1, survey1 = survey1) + +test_that("create_default_parameters handles empty data object", { + empty_data <- NULL + + expect_error(create_default_parameters(empty_data, fleets = fleets)) +}) + +test_that("create_default_parameters returns correct structure", { + + result <- create_default_parameters(data, fleets = fleets) + + expect_named(result, c("parameters", "modules")) + expect_type(result[["parameters"]], "list") + expect_type(result[["modules"]], "list") + expect_named(result[["modules"]], c("fleets", "recruitment", "growth", "maturity")) +}) + +test_that("create_default_parameters detects missing fleet names", { + invalid_fleet <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution" + ) + ) + + invalid_fleets = list( + fleet1 = fleet1, + survey1 = survey1, + invalid_fleet = invalid_fleet + ) + + expect_error( + create_default_parameters(data, invalid_fleets), + "The following 1 fleet name is missing from the data: invalid_fleet" + ) +}) diff --git a/tests/testthat/test-create_rcpp_interface_object.R b/tests/testthat/test-create_rcpp_interface_object.R index 95afb7f49..e22ef21d2 100644 --- a/tests/testthat/test-create_rcpp_interface_object.R +++ b/tests/testthat/test-create_rcpp_interface_object.R @@ -8,7 +8,6 @@ # base_class = "DistributionsInterfaceBase", # container = "distribution_models", # parameters = c("x", "mean", "sd"), -# evaluate_parameter = "do_log", # evaluate_parameter_type = "bool" # ), # cran = FALSE, diff --git a/tests/testthat/test-distribution-formulas.R b/tests/testthat/test-distribution-formulas.R new file mode 100644 index 000000000..74df34674 --- /dev/null +++ b/tests/testthat/test-distribution-formulas.R @@ -0,0 +1,173 @@ +load(test_path("fixtures", "integration_test_data.RData")) +iter_id <- 1 +# Load operating model data +om_input <- om_input_list[[iter_id]] +om_output <- om_output_list[[iter_id]] +em_input <- em_input_list[[iter_id]] + +# Clear any previous FIMS settings +clear() + +test_that("test initialize_process_distribution", { + # Recruitment + # create new module in the recruitment class (specifically Beverton-Holt, + # when there are other options, this would be where the option would be chosen) + recruitment <- methods::new(BevertonHoltRecruitment) + + # set up log_rzero (equilibrium recruitment) + recruitment$log_rzero[1]$value <- log(om_input$R0) + recruitment$log_rzero[1]$is_random_effect <- FALSE + recruitment$log_rzero[1]$estimated <- TRUE + # set up logit_steep + recruitment$logit_steep[1]$value <- -log(1.0 - om_input$h) + + log(om_input$h - 0.2) + recruitment$logit_steep[1]$is_random_effect <- FALSE + recruitment$logit_steep[1]$estimated <- FALSE + # turn on estimation of deviations + # recruit deviations should enter the model in normal space. + # The log is taken in the likelihood calculations + # alternative setting: recruitment$log_devs <- rep(0, length(om_input$logR.resid)) + recruitment$log_devs <- methods::new( + ParameterVector, + om_input$logR.resid[-1], + om_input$nyr - 1 + ) + + # set up logR_sd using the normal log_sd parameter + recruitment_distribution <- initialize_process_distribution( + module = recruitment, + par = "log_devs", + family = gaussian(), + sd = list(value = om_input$logR_sd, estimated = FALSE), + is_random_effect = FALSE + ) + recruitment$estimate_log_devs <- TRUE + + expect_equal(log(om_input$logR_sd), recruitment_distribution$log_sd[1]$value) + expect_equal(length(recruitment$log_devs), length(recruitment_distribution$x)) + expect_equal( + length(recruitment_distribution$x), + length(recruitment_distribution$expected_values) + ) + expect_error( + initialize_process_distribution( + module = recruitment, + par = "log_devs", + family = multinomial(), + sd = list(value = om_input$logR_sd, estimated = FALSE), + is_random_effect = FALSE + ) + ) + expect_error( + initialize_process_distribution( + module = recruitment, + par = "log_devs", + family = binomial(), + sd = list(value = om_input$logR_sd, estimated = FALSE), + is_random_effect = FALSE + ) + ) + expect_error( + initialize_process_distribution( + module = recruitment, + par = "log_devs", + family = gaussian(), + sd = list(value = -1, estimated = FALSE), + is_random_effect = FALSE + ) + ) + expect_error( + initialize_process_distribution( + module = recruitment, + par = "log_devs", + family = gaussian(), + sd = list( + value = rep(om_input$logR_sd, 3), + estimated = rep(FALSE, 2) + ), + is_random_effect = FALSE + ) + ) + clear() +}) + + +test_that("test initialize_data_distribution", { + # Data + catch <- em_input$L.obs$fleet1 + # set fishing fleet catch data, need to set dimensions of data index + # currently FIMS only has a fleet module that takes index for both survey index and fishery catch + fishing_fleet_index <- methods::new(Index, om_input$nyr) + fishing_fleet_index$index_data <- catch + fishing_fleet <- methods::new(Fleet) + fishing_fleet$nages <- om_input$nages + fishing_fleet$nyears <- om_input$nyr + fishing_fleet$log_Fmort <- methods::new(ParameterVector, log(om_output$f), om_input$nyr) + fishing_fleet$log_Fmort$set_all_estimable(TRUE) + fishing_fleet$log_q[1]$value <- log(1.0) + fishing_fleet$estimate_q <- FALSE + fishing_fleet$random_q <- FALSE + fishing_fleet$SetObservedIndexData(fishing_fleet_index$get_id()) + + # Set up fishery index data using the lognormal + fleet_sd <- rep(sqrt(log(em_input$cv.L$fleet1^2 + 1)), om_input$nyr) + fishing_fleet_index_distribution <- initialize_data_distribution( + module = fishing_fleet, + family = lognormal(link = "log"), + sd = list(value = fleet_sd, estimated = FALSE), + data_type = "index" + ) + expect_equal( + log(fleet_sd[1]), + fishing_fleet_index_distribution$log_sd[1]$value + ) + expect_error( + initialize_data_distribution( + module = fishing_fleet, + family = multinomial(), + sd = list(value = fleet_sd, estimated = FALSE), + data_type = "index" + ) + ) + expect_error( + initialize_data_distribution( + module = fishing_fleet, + family = multinomial(), + sd = list(value = fleet_sd, estimated = FALSE), + data_type = "index" + ) + ) + expect_error( + initialize_data_distribution( + module = fishing_fleet, + family = gaussian(), + sd = list(value = fleet_sd, estimated = FALSE), + data_type = "agecomp" + ) + ) + expect_error( + initialize_data_distribution( + module = fishing_fleet, + family = lognormal(), + sd = list(value = fleet_sd, estimated = FALSE), + data_type = "lengthcomp" + ) + ) + expect_error( + initialize_data_distribution( + module = fishing_fleet, + family = multinomial(), + sd = list(value = fleet_sd, estimated = c(FALSE, FALSE)), + data_type = "agecomp" + ) + ) + expect_error( + initialize_data_distribution( + module = fishing_fleet, + family = multinomial(), + sd = list(value = fleet_sd), + data_type = "agecomp" + ) + ) + clear() +}) diff --git a/tests/testthat/test-fimsfit.R b/tests/testthat/test-fimsfit.R new file mode 100644 index 000000000..11ef3763b --- /dev/null +++ b/tests/testthat/test-fimsfit.R @@ -0,0 +1,45 @@ +test_that("FIMSFit() creates an object of class 'FIMSFit'", { + fit_obj <- list(version = "1.0", timing = list(time_total = 10), opt = list(num_pars = list(total = 10, fixed_effects = 5, random_effects = 5)), rep = list(ssb = 1), parList = list(), obj = NULL) + result <- FIMSFit( + input = list(), + timing = c(time_total = as.difftime(10, units = "secs")), + obj = list( + par = NA, fn = NA, gr = NA, he = NA, hessian = NA, method = NA, + retape = NA, + env = list("last.par.best" = 1, "parList" = function(x) { + list("p" = TRUE) + }), + report = function(x) { + list(TRUE) + }, simulate = NA + ) + ) + + expect_s4_class(result, "FIMSFit") + expect_true(inherits(result, "FIMSFit")) + expect_snapshot( + print(result) + ) +}) + +test_that("FIMSFit is not returned from a strong", { + expect_false(is.FIMSFit("not_a_FIMSFit")) +}) + +test_that("FIMSFit() stops for missing input", { + expect_error( + FIMSFit( + obj = list( + par = NA, fn = NA, gr = NA, he = NA, hessian = NA, method = NA, + retape = NA, + env = list("last.par.best" = 1, "parList" = function(x) { + list("p" = TRUE) + }), + report = function(x) { + list(TRUE) + }, simulate = NA + ) + ), + "missing, with no default" + ) +}) diff --git a/tests/testthat/test-fimsframe.R b/tests/testthat/test-fimsframe.R index f50a4c663..5745fb965 100644 --- a/tests/testthat/test-fimsframe.R +++ b/tests/testthat/test-fimsframe.R @@ -1,14 +1,13 @@ # tests for input objects -data(package = "FIMS") -fims_frame <- FIMSFrame(data_mile1) +data("data1", package = "FIMS") +fims_frame <- FIMSFrame(data1) test_that("Can create the S4 FIMSFrame classes", { expect_s4_class(fims_frame, "FIMSFrame") # A data frame is an S3 object with class data.frame - expect_s3_class(fims_frame@weight_at_age, "data.frame") - expect_s3_class(fims_frame@data, "data.frame") + expect_s3_class(get_data(fims_frame), "data.frame") - expect_s3_class(fims_frame@data, "data.frame") + expect_s3_class(get_data(fims_frame), "data.frame") # A helper function that creates a figure from code save_png <- function(code, width = 1000, height = 1000) { @@ -25,62 +24,54 @@ test_that("Can create the S4 FIMSFrame classes", { test_that("Accessors work as expected in FIMSFrame", { expect_s3_class(get_data(fims_frame), "data.frame") - expect_vector(fleets(fims_frame), ptype = numeric()) + expect_vector(get_fleets(fims_frame), ptype = numeric()) - expect_type(n_years(fims_frame), "integer") - expect_length(n_years(fims_frame), 1) + expect_type(get_n_years(fims_frame), "integer") + expect_length(get_n_years(fims_frame), 1) - expect_type(start_year(fims_frame), "integer") - expect_length(start_year(fims_frame), 1) + expect_type(get_start_year(fims_frame), "integer") + expect_length(get_start_year(fims_frame), 1) - expect_type(end_year(fims_frame), "integer") - expect_length(end_year(fims_frame), 1) + expect_type(get_end_year(fims_frame), "integer") + expect_length(get_end_year(fims_frame), 1) expect_s3_class(get_data(fims_frame), "data.frame") - expect_vector(fleets(fims_frame), ptype = numeric()) - - expect_type(n_years(fims_frame), "integer") - expect_length(n_years(fims_frame), 1) + expect_vector(get_fleets(fims_frame), ptype = numeric()) - expect_type(start_year(fims_frame), "integer") - expect_length(start_year(fims_frame), 1) + expect_type(get_n_years(fims_frame), "integer") + expect_length(get_n_years(fims_frame), 1) - expect_type(end_year(fims_frame), "integer") - expect_length(end_year(fims_frame), 1) + expect_type(get_start_year(fims_frame), "integer") + expect_length(get_start_year(fims_frame), 1) + expect_type(get_end_year(fims_frame), "integer") + expect_length(get_end_year(fims_frame), 1) - expect_vector(ages(fims_frame), ptype = integer()) - expect_type(n_ages(fims_frame), "integer") - expect_length(n_ages(fims_frame), 1) + expect_vector(get_ages(fims_frame), ptype = integer()) - expect_s3_class(weight_at_age(fims_frame), "data.frame") + expect_type(get_n_ages(fims_frame), "integer") + expect_length(get_n_ages(fims_frame), 1) expect_vector(m_weight_at_age(fims_frame), ptype = numeric()) - expect_vector(m_ages(fims_frame), ptype = integer()) }) test_that("Show method works as expected", { expect_output(show(fims_frame)) - - empty_obj <- fims_frame - empty_obj@data <- data.frame(matrix(nrow = 0, ncol = 0)) - expect_null(show(empty_obj)) }) - test_that("Validators work as expected", { bad_input <- data.frame(test = 1, test2 = 2) expect_error(FIMSFrame(bad_input)) }) -n_years <- fims_frame@n_years -n_ages <- max(fims_frame@ages) +n_years <- get_n_years(fims_frame) +n_ages <- get_n_ages(fims_frame) fleet_names_age_comp <- dplyr::filter( - .data = as.data.frame(fims_frame@data), + .data = as.data.frame(get_data(fims_frame)), type == "age" ) |> dplyr::distinct(name) |> @@ -88,7 +79,7 @@ fleet_names_age_comp <- dplyr::filter( n_age_comp <- length(fleet_names_age_comp) fleet_names_index <- dplyr::filter( - .data = as.data.frame(fims_frame@data), + .data = as.data.frame(get_data(fims_frame)), type == "index" ) |> dplyr::distinct(name) |> @@ -101,7 +92,7 @@ test_that("Can add index data to model", { for (index_i in 1:n_index) { index <- Index - index_dat[[fleet_names_index[index_i]]] <- new(index, n_years) + index_dat[[fleet_names_index[index_i]]] <- methods::new(index, n_years) expect_silent(index_dat[[fleet_names_index[index_i]]] <- m_index(fims_frame, fleet_names_index[index_i])) } @@ -114,7 +105,7 @@ test_that("Can add agecomp data to model", { names(age_comp_dat) <- fleet_names_age_comp for (fleet_f in 1:n_age_comp) { - age_comp_dat[[fleet_names_age_comp[fleet_f]]] <- new(AgeComp, n_years, n_ages) + age_comp_dat[[fleet_names_age_comp[fleet_f]]] <- methods::new(AgeComp, n_years, n_ages) expect_silent(age_comp_dat[[fleet_names_age_comp[fleet_f]]]$age_comp_data <- m_agecomp(fims_frame, fleet_names_age_comp[fleet_f])) } diff --git a/tests/testthat/test-initialize_modules.R b/tests/testthat/test-initialize_modules.R new file mode 100644 index 000000000..1a9b2b53c --- /dev/null +++ b/tests/testthat/test-initialize_modules.R @@ -0,0 +1,61 @@ +data("data1") +data <- FIMSFrame(data1) + +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) +) + +fleets = list(fleet1 = fleet1, survey1 = survey1) + +default_parameters <- create_default_parameters(data, fleets = fleets) + +test_that("initialize_fims handles missing parameters input correctly", { + expect_error( + initialize_fims(data = data), + "argument must be a non-missing list." + ) + clear() +}) + +test_that("initialize_fims handles non-list parameters input correctly", { + expect_error( + initialize_fims(parameters = "not_a_list", data = data), + "argument must be a non-missing list." + ) + clear() +}) + +test_that("initialize_fims fails when no fleets are provided", { + parameters_no_fleets <- default_parameters + parameters_no_fleets[["modules"]][["fleets"]] <- NULL + expect_error( + initialize_fims(parameters = parameters_no_fleets, data = data), + "No fleets found in the provided" + ) + clear() +}) + +test_that("initialize_fims works", { + + result <- initialize_fims(parameters = default_parameters, data = data) + + expect_type(result, "list") + expect_named(result, "parameters") + clear() +}) + +test_that("initialize_fims clears previous FIMS settings before initializing", { + mock_clear <- mockery::mock() + mockery::stub(initialize_fims, "clear", mock_clear) + + initialize_fims(parameters = default_parameters, data = data) + + mockery::expect_called(mock_clear, 1) + clear() +}) + diff --git a/tests/testthat/test-integration-fims-estimation-with-wrappers.R b/tests/testthat/test-integration-fims-estimation-with-wrappers.R new file mode 100644 index 000000000..0da84332d --- /dev/null +++ b/tests/testthat/test-integration-fims-estimation-with-wrappers.R @@ -0,0 +1,442 @@ +load(test_path("fixtures", "integration_test_data.RData")) + +test_that("deterministic test of fims", { + iter_id <- 1 + + result <- setup_and_run_FIMS_with_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = FALSE + ) + + # Call report using deterministic parameter values + # obj[["report"]]() requires parameter list to avoid errors + report <- result@report + + # Compare log(R0) to true value + fims_logR0 <- as.numeric(result@obj[["par"]][36]) + expect_gt(fims_logR0, 0.0) + expect_equal(fims_logR0, log(om_input_list[[iter_id]][["R0"]])) + + # Compare numbers at age to true value + for (i in 1:length(c(t(om_output_list[[iter_id]][["N.age"]])))) { + expect_equal(report[["naa"]][[1]][i], c(t(om_output_list[[iter_id]][["N.age"]]))[i]) + } + + # Compare biomass to true value + for (i in 1:length(om_output_list[[iter_id]][["biomass.mt"]])) { + expect_equal(report[["biomass"]][[1]][i], om_output_list[[iter_id]][["biomass.mt"]][i]) + } + + # Compare spawning biomass to true value + for (i in 1:length(om_output_list[[iter_id]][["SSB"]])) { + expect_equal(report[["ssb"]][[1]][i], om_output_list[[iter_id]][["SSB"]][i]) + } + + # Compare recruitment to true value + fims_naa <- matrix(report[["naa"]][[1]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + + # loop over years to compare recruitment by year + for (i in 1:om_input_list[[iter_id]][["nyr"]]) { + expect_equal(fims_naa[i, 1], om_output_list[[iter_id]][["N.age"]][i, 1]) + } + + # confirm that recruitment matches the numbers in the first age + # by comparing to fims_naa (what's reported from FIMS) + expect_equal( + fims_naa[1:om_input_list[[iter_id]][["nyr"]], 1], + report[["recruitment"]][[1]][1:om_input_list[[iter_id]][["nyr"]]] + ) + + # confirm that recruitment matches the numbers in the first age + # by comparing to the true values from the OM + for (i in 1:om_input_list[[iter_id]][["nyr"]]) { + expect_equal(report[["recruitment"]][[1]][i], om_output_list[[iter_id]][["N.age"]][i, 1]) + } + + # recruitment log_devs (fixed at initial "true" values) + # the initial value of om_input[["logR.resid"]] is dropped from the model + expect_equal(report[["log_recruit_dev"]][[1]], om_input_list[[iter_id]][["logR.resid"]][-1]) + + # F (fixed at initial "true" values) + expect_equal(report[["F_mort"]][[1]], om_output_list[[iter_id]][["f"]]) + + # Expected catch + fims_index <- report[["exp_index"]] + for (i in 1:length(om_output_list[[iter_id]][["L.mt"]][["fleet1"]])) { + expect_equal(fims_index[[1]][i], om_output_list[[iter_id]][["L.mt"]][["fleet1"]][i]) + } + + # Expect small relative error for deterministic test + fims_object_are <- rep(0, length(em_input_list[[iter_id]][["L.obs"]][["fleet1"]])) + for (i in 1:length(em_input_list[[iter_id]][["L.obs"]][["fleet1"]])) { + fims_object_are[i] <- abs(fims_index[[1]][i] - em_input_list[[iter_id]][["L.obs"]][["fleet1"]][i]) / em_input_list[[iter_id]][["L.obs"]][["fleet1"]][i] + } + + # Expect 95% of relative error to be within 2*cv + expect_lte(sum(fims_object_are > om_input_list[[iter_id]][["cv.L"]][["fleet1"]] * 2.0), length(em_input_list[[iter_id]][["L.obs"]][["fleet1"]]) * 0.05) + + # Compare expected catch number at age to true values + for (i in 1:length(c(t(om_output_list[[iter_id]][["L.age"]][["fleet1"]])))) { + expect_equal(report[["cnaa"]][[1]][i], c(t(om_output_list[[iter_id]][["L.age"]][["fleet1"]]))[i]) + } + + # Expected catch number at age in proportion + # QUESTION: Isn't this redundant with the non-proportion test above? + fims_cnaa <- matrix(report[["cnaa"]][[1]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + fims_cnaa_proportion <- fims_cnaa / rowSums(fims_cnaa) + om_cnaa_proportion <- om_output_list[[iter_id]][["L.age"]][["fleet1"]] / rowSums(om_output_list[[iter_id]][["L.age"]][["fleet1"]]) + + for (i in 1:length(c(t(om_cnaa_proportion)))) { + expect_equal(c(t(fims_cnaa_proportion))[i], c(t(om_cnaa_proportion))[i]) + } + + # Expected survey index. + # Using [[2]] because the survey is the 2nd fleet. + cwaa <- matrix(report[["cwaa"]][[2]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + expect_equal(fims_index[[2]], apply(cwaa, 1, sum) * om_output_list[[iter_id]][["survey_q"]][["survey1"]]) + + for (i in 1:length(om_output_list[[iter_id]][["survey_index_biomass"]][["survey1"]])) { + expect_equal(fims_index[[2]][i], om_output_list[[iter_id]][["survey_index_biomass"]][["survey1"]][i]) + } + + fims_object_are <- rep(0, length(em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]])) + for (i in 1:length(em_input_list[[iter_id]][["survey.obs"]][["survey1"]])) { + fims_object_are[i] <- abs(fims_index[[2]][i] - em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]][i]) / em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]][i] + } + # Expect 95% of relative error to be within 2*cv + expect_lte( + sum(fims_object_are > om_input_list[[iter_id]][["cv.survey"]][["survey1"]] * 2.0), + length(em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]]) * 0.05 + ) + + # Expected catch number at age in proportion + fims_cnaa <- matrix(report[["cnaa"]][[2]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + + for (i in 1:length(c(t(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]])))) { + expect_equal(report[["cnaa"]][[2]][i], c(t(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]]))[i]) + } + + fims_cnaa_proportion <- fims_cnaa / rowSums(fims_cnaa) + om_cnaa_proportion <- om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]] / rowSums(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]]) + + for (i in 1:length(c(t(om_cnaa_proportion)))) { + expect_equal(c(t(fims_cnaa_proportion))[i], c(t(om_cnaa_proportion))[i]) + } +}) + +test_that("nll test of fims", { + iter_id <- 1 + + result <- setup_and_run_FIMS_with_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = FALSE + ) + + # Set up TMB's computational graph + obj <- result@obj + report <- result@report + + # Calculate standard errors + # sdr <- result@sdreport + # sdr_fixed <- result[["sdr_fixed"]] + + # log(R0) + fims_logR0 <- as.numeric(result@obj[["par"]][36]) + expect_equal(fims_logR0, log(om_input_list[[iter_id]][["R0"]])) + + # recruitment likelihood + # log_devs is of length nyr-1 + rec_nll <- -sum(dnorm( + om_input_list[[iter_id]][["logR.resid"]][-1], rep(0, om_input_list[[iter_id]][["nyr"]] - 1), + om_input_list[[iter_id]][["logR_sd"]], TRUE + )) + + # catch and survey index expected likelihoods + index_nll_fleet <- -sum(dlnorm( + em_input_list[[iter_id]][["L.obs"]][["fleet1"]], + log(om_output_list[[iter_id]][["L.mt"]][["fleet1"]]), + sqrt(log(em_input_list[[iter_id]][["cv.L"]][["fleet1"]]^2 + 1)), TRUE + )) + index_nll_survey <- -sum(dlnorm( + em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]], + log(om_output_list[[iter_id]][["survey_index_biomass"]][["survey1"]]), + sqrt(log(em_input_list[[iter_id]][["cv.survey"]][["survey1"]]^2 + 1)), TRUE + )) + index_nll <- index_nll_fleet + index_nll_survey + # age comp likelihoods + fishing_acomp_observed <- em_input_list[[iter_id]][["L.age.obs"]][["fleet1"]] + fishing_acomp_expected <- om_output_list[[iter_id]][["L.age"]][["fleet1"]] / rowSums(om_output_list[[iter_id]][["L.age"]][["fleet1"]]) + survey_acomp_observed <- em_input_list[[iter_id]][["survey.age.obs"]][["survey1"]] + survey_acomp_expected <- om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]] / rowSums(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]]) + age_comp_nll_fleet <- age_comp_nll_survey <- 0 + for (y in 1:om_input_list[[iter_id]][["nyr"]]) { + age_comp_nll_fleet <- age_comp_nll_fleet - + dmultinom( + fishing_acomp_observed[y, ] * em_input_list[[iter_id]][["n.L"]][["fleet1"]], em_input_list[[iter_id]][["n.L"]][["fleet1"]], + fishing_acomp_expected[y, ], TRUE + ) + + age_comp_nll_survey <- age_comp_nll_survey - + dmultinom( + survey_acomp_observed[y, ] * em_input_list[[iter_id]][["n.survey"]][["survey1"]], em_input_list[[iter_id]][["n.survey"]][["survey1"]], + survey_acomp_expected[y, ], TRUE + ) + } + age_comp_nll <- age_comp_nll_fleet + age_comp_nll_survey + + # length comp likelihoods + # TODO: the commented-out code below is not working yet + # fishing_lengthcomp_observed <- em_input_list[[iter_id]][["L.length.obs"]][["fleet1"]] + # fishing_lengthcomp_expected <- om_output_list[[iter_id]][["L.length"]][["fleet1"]] / rowSums(om_output_list[[iter_id]][["L.length"]][["fleet1"]]) + # survey_lengthcomp_observed <- em_input_list[[iter_id]][["survey.length.obs"]][["survey1"]] + # survey_lengthcomp_expected <- om_output_list[[iter_id]][["survey_length_comp"]][["survey1"]] / rowSums(om_output_list[[iter_id]][["survey_length_comp"]][["survey1"]]) + # lengthcomp_nll_fleet <- lengthcomp_nll_survey <- 0 + # for (y in 1:om_input_list[[iter_id]][["nyr"]]) { + # + # lengthcomp_nll_fleet <- lengthcomp_nll_fleet - + # dmultinom( + # fishing_lengthcomp_observed[y, ] * em_input_list[[iter_id]][["n.L.lengthcomp"]][["fleet1"]], em_input_list[[iter_id]][["n.L.lengthcomp"]][["fleet1"]], + # fishing_lengthcomp_expected[y, ], TRUE + # ) + # + # lengthcomp_nll_survey <- lengthcomp_nll_survey - + # dmultinom( + # survey_lengthcomp_observed[y, ] * em_input_list[[iter_id]][["n.survey.lengthcomp"]][["survey1"]], em_input_list[[iter_id]][["n.survey.lengthcomp"]][["survey1"]], + # survey_lengthcomp_expected[y, ], TRUE + # ) + # } + # lengthcomp_nll <- lengthcomp_nll_fleet + lengthcomp_nll_survey + # + # expected_jnll <- rec_nll + index_nll + age_comp_nll + lengthcomp_nll + # jnll <- report[["jnll"]] + + expect_equal(report[["nll_components"]][1], rec_nll) + expect_equal(report[["nll_components"]][2], index_nll_fleet) + expect_equal(report[["nll_components"]][3], age_comp_nll_fleet) + # expect_equal(report[["nll_components"]][4], lengthcomp_nll_fleet) + expect_equal(report[["nll_components"]][5], index_nll_survey) + expect_equal(report[["nll_components"]][6], age_comp_nll_survey) + # expect_equal(report[["nll_components"]][7], lengthcomp_nll_survey) + # expect_equal(jnll, expected_jnll) +}) + +test_that("estimation test of fims using wrapper functions", { + # Initialize the iteration identifier and run FIMS with the 1st set of OM values + iter_id <- 1 + result <- setup_and_run_FIMS_with_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = TRUE + ) + + # Compare FIMS results with model comparison project OM values + validate_fims( + report = result@report, + sdr = result@estimates, + sdr_report = result@estimates, + 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("estimation test with age and length comp using wrappers",{ + # Load operating model data for the current iteration + iter_id <- 1 + om_input <- om_input_list[[iter_id]] + om_output <- om_output_list[[iter_id]] + em_input <- em_input_list[[iter_id]] + + fims_data <- FIMS::FIMSFrame(data1) + + # Clear any previous FIMS settings + clear() + + fleets <- list( + fleet1 = list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) + ), + survey1 = list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) + ) + ) + + lengthcomp_parameters <- fims_data |> + create_default_parameters( + fleets = fleets, + recruitment = list( + form = "BevertonHoltRecruitment", + process_distribution = c(log_devs = "DnormDistribution") + ), + growth = list(form = "EWAAgrowth"), + maturity = list(form = "LogisticMaturity") + ) + + modified_parameters <- list( + fleet1 = list( + Fleet.log_Fmort.value = log(om_output_list[[1]][["f"]]) + ), + survey1 = list( + LogisticSelectivity.inflection_point.value = 1.5, + LogisticSelectivity.slope.value = 2, + Fleet.log_q.value = log(om_output_list[[1]][["survey_q"]][["survey1"]]) + ), + recruitment = list( + BevertonHoltRecruitment.log_rzero.value = log(om_input_list[[1]][["R0"]]), + BevertonHoltRecruitment.log_devs.value = om_input_list[[1]][["logR.resid"]][-1], + BevertonHoltRecruitment.log_devs.estimated = FALSE, + DnormDistribution.log_sd.value = om_input_list[[1]][["logR_sd"]] + ), + maturity = list( + LogisticMaturity.inflection_point.value = om_input_list[[1]][["A50.mat"]], + LogisticMaturity.inflection_point.estimated = FALSE, + LogisticMaturity.slope.value = om_input_list[[1]][["slope.mat"]], + LogisticMaturity.slope.estimated = FALSE + ), + population = list( + Population.log_init_naa.value = log(om_output_list[[1]][["N.age"]][1, ]) + ) + ) + + parameters <- lengthcomp_parameters |> + update_parameters( + modified_parameters = modified_parameters + ) + + parameter_list <- initialize_fims( + parameters = parameters, + data = fims_data + ) + fit <- fit_fims(parameter_list, optimize = TRUE) + + clear() + + validate_fims( + report = fit@report, + sdr = fit@estimates, + sdr_report = fit@estimates, + 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("estimation test with length comp using wrappers",{ + # Load operating model data for the current iteration + iter_id <- 1 + om_input <- om_input_list[[iter_id]] + om_output <- om_output_list[[iter_id]] + em_input <- em_input_list[[iter_id]] + + fims_data <- data1 |> + dplyr::filter(type != "age") |> + FIMS::FIMSFrame() + + # Clear any previous FIMS settings + clear() + + fleets <- list( + fleet1 = list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + LengthComp = "DmultinomDistribution" + ) + ), + survey1 = list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + LengthComp = "DmultinomDistribution" + ) + ) + ) + + lengthcomp_parameters <- fims_data |> + create_default_parameters( + fleets = fleets, + recruitment = list( + form = "BevertonHoltRecruitment", + process_distribution = c(log_devs = "DnormDistribution") + ), + growth = list(form = "EWAAgrowth"), + maturity = list(form = "LogisticMaturity") + ) + + modified_parameters <- list( + fleet1 = list( + Fleet.log_Fmort.value = log(om_output_list[[1]][["f"]]) + ), + survey1 = list( + LogisticSelectivity.inflection_point.value = 1.5, + LogisticSelectivity.slope.value = 2, + Fleet.log_q.value = log(om_output_list[[1]][["survey_q"]][["survey1"]]) + ), + recruitment = list( + BevertonHoltRecruitment.log_rzero.value = log(om_input_list[[1]][["R0"]]), + BevertonHoltRecruitment.log_devs.value = om_input_list[[1]][["logR.resid"]][-1], + BevertonHoltRecruitment.log_devs.estimated = FALSE, + DnormDistribution.log_sd.value = om_input_list[[1]][["logR_sd"]] + ), + maturity = list( + LogisticMaturity.inflection_point.value = om_input_list[[1]][["A50.mat"]], + LogisticMaturity.inflection_point.estimated = FALSE, + LogisticMaturity.slope.value = om_input_list[[1]][["slope.mat"]], + LogisticMaturity.slope.estimated = FALSE + ), + population = list( + Population.log_init_naa.value = log(om_output_list[[1]][["N.age"]][1, ]) + ) + ) + + parameters <- lengthcomp_parameters |> + update_parameters( + modified_parameters = modified_parameters + ) + + parameter_list <- initialize_fims( + parameters = parameters, + data = fims_data + ) + fit <- fit_fims(parameter_list, optimize = TRUE) + + clear() + + validate_fims( + report = fit@report, + sdr = fit@estimates, + sdr_report = fit@estimates, + om_input = om_input_list[[iter_id]], + om_output = om_output_list[[iter_id]], + em_input = em_input_list[[iter_id]], + use_fimsfit = TRUE + ) +}) diff --git a/tests/testthat/test-integration-fims-estimation-without-wrappers.R b/tests/testthat/test-integration-fims-estimation-without-wrappers.R new file mode 100644 index 000000000..f1f25cfec --- /dev/null +++ b/tests/testthat/test-integration-fims-estimation-without-wrappers.R @@ -0,0 +1,334 @@ +# Load test data for integration testing +# The test data is stored as an RData file in the tests/testthat/fixtures folder, +# which contains 100 sets of simulated data using {ASSAMC} from +# https://github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison. +load(test_path("fixtures", "integration_test_data.RData")) + +# Initialize the iteration identifier and run FIMS with the 1st set of OM values +iter_id <- 1 + +test_that("deterministic test of fims", { + + result <- setup_and_run_FIMS_without_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = FALSE + ) + + # Set up TMB's computational graph + obj <- result[["obj"]] + + # Calculate standard errors + sdr <- result[["sdr"]] + sdr_fixed <- result[["sdr_fixed"]] + + # Call report using deterministic parameter values + # obj[["report"]]() requires parameter list to avoid errors + report <- result[["report"]] + + # Compare log(R0) to true value + fims_logR0 <- sdr_fixed[36, "Estimate"] + expect_gt(fims_logR0, 0.0) + expect_equal(fims_logR0, log(om_input_list[[iter_id]][["R0"]])) + + # Compare numbers at age to true value + for (i in 1:length(c(t(om_output_list[[iter_id]][["N.age"]])))) { + expect_equal(report[["naa"]][[1]][i], c(t(om_output_list[[iter_id]][["N.age"]]))[i]) + } + + # Compare biomass to true value + for (i in 1:length(om_output_list[[iter_id]][["biomass.mt"]])) { + expect_equal(report[["biomass"]][[1]][i], om_output_list[[iter_id]][["biomass.mt"]][i]) + } + + # Compare spawning biomass to true value + for (i in 1:length(om_output_list[[iter_id]][["SSB"]])) { + expect_equal(report[["ssb"]][[1]][i], om_output_list[[iter_id]][["SSB"]][i]) + } + + # Compare recruitment to true value + fims_naa <- matrix(report[["naa"]][[1]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + + # loop over years to compare recruitment by year + for (i in 1:om_input_list[[iter_id]][["nyr"]]) { + expect_equal(fims_naa[i, 1], om_output_list[[iter_id]][["N.age"]][i, 1]) + } + + # confirm that recruitment matches the numbers in the first age + # by comparing to fims_naa (what's reported from FIMS) + expect_equal( + fims_naa[1:om_input_list[[iter_id]][["nyr"]], 1], + report[["recruitment"]][[1]][1:om_input_list[[iter_id]][["nyr"]]] + ) + + # confirm that recruitment matches the numbers in the first age + # by comparing to the true values from the OM + for (i in 1:om_input_list[[iter_id]][["nyr"]]) { + expect_equal(report[["recruitment"]][[1]][i], om_output_list[[iter_id]][["N.age"]][i, 1]) + } + + # recruitment log_devs (fixed at initial "true" values) + # the initial value of om_input[["logR.resid"]] is dropped from the model + expect_equal(report[["log_recruit_dev"]][[1]], om_input_list[[iter_id]][["logR.resid"]][-1]) + + # F (fixed at initial "true" values) + expect_equal(report[["F_mort"]][[1]], om_output_list[[iter_id]][["f"]]) + + # Expected catch + fims_index <- report[["exp_index"]] + for (i in 1:length(om_output_list[[iter_id]][["L.mt"]][["fleet1"]])) { + expect_equal(fims_index[[1]][i], om_output_list[[iter_id]][["L.mt"]][["fleet1"]][i]) + } + + # Expect small relative error for deterministic test + fims_object_are <- rep(0, length(em_input_list[[iter_id]][["L.obs"]][["fleet1"]])) + for (i in 1:length(em_input_list[[iter_id]][["L.obs"]][["fleet1"]])) { + fims_object_are[i] <- abs(fims_index[[1]][i] - em_input_list[[iter_id]][["L.obs"]][["fleet1"]][i]) / em_input_list[[iter_id]][["L.obs"]][["fleet1"]][i] + } + + # Expect 95% of relative error to be within 2*cv + expect_lte(sum(fims_object_are > om_input_list[[iter_id]][["cv.L"]][["fleet1"]] * 2.0), length(em_input_list[[iter_id]][["L.obs"]][["fleet1"]]) * 0.05) + + # Compare expected catch number at age to true values + for (i in 1:length(c(t(om_output_list[[iter_id]][["L.age"]][["fleet1"]])))) { + expect_equal(report[["cnaa"]][[1]][i], c(t(om_output_list[[iter_id]][["L.age"]][["fleet1"]]))[i]) + } + + # Expected catch number at age in proportion + # QUESTION: Isn't this redundant with the non-proportion test above? + fims_cnaa <- matrix(report[["cnaa"]][[1]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + fims_cnaa_proportion <- fims_cnaa / rowSums(fims_cnaa) + om_cnaa_proportion <- om_output_list[[iter_id]][["L.age"]][["fleet1"]] / rowSums(om_output_list[[iter_id]][["L.age"]][["fleet1"]]) + + for (i in 1:length(c(t(om_cnaa_proportion)))) { + expect_equal(c(t(fims_cnaa_proportion))[i], c(t(om_cnaa_proportion))[i]) + } + + # Expected survey index. + # Using [[2]] because the survey is the 2nd fleet. + cwaa <- matrix(report[["cwaa"]][[2]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + expect_equal(fims_index[[2]], apply(cwaa, 1, sum) * om_output_list[[iter_id]][["survey_q"]][["survey1"]]) + + for (i in 1:length(om_output_list[[iter_id]][["survey_index_biomass"]][["survey1"]])) { + expect_equal(fims_index[[2]][i], om_output_list[[iter_id]][["survey_index_biomass"]][["survey1"]][i]) + } + + fims_object_are <- rep(0, length(em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]])) + for (i in 1:length(em_input_list[[iter_id]][["survey.obs"]][["survey1"]])) { + fims_object_are[i] <- abs(fims_index[[2]][i] - em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]][i]) / em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]][i] + } + # Expect 95% of relative error to be within 2*cv + expect_lte( + sum(fims_object_are > om_input_list[[iter_id]][["cv.survey"]][["survey1"]] * 2.0), + length(em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]]) * 0.05 + ) + + # Expected catch number at age in proportion + fims_cnaa <- matrix(report[["cnaa"]][[2]][1:(om_input_list[[iter_id]][["nyr"]] * om_input_list[[iter_id]][["nages"]])], + nrow = om_input_list[[iter_id]][["nyr"]], byrow = TRUE + ) + + for (i in 1:length(c(t(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]])))) { + expect_equal(report[["cnaa"]][[2]][i], c(t(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]]))[i]) + } + + fims_cnaa_proportion <- fims_cnaa / rowSums(fims_cnaa) + om_cnaa_proportion <- om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]] / rowSums(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]]) + + for (i in 1:length(c(t(om_cnaa_proportion)))) { + expect_equal(c(t(fims_cnaa_proportion))[i], c(t(om_cnaa_proportion))[i]) + } +}) + +test_that("nll test of fims", { + + result <- setup_and_run_FIMS_without_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = FALSE + ) + + # Set up TMB's computational graph + obj <- result[["obj"]] + report <- result[["report"]] + + # Calculate standard errors + sdr <- result[["sdr"]] + sdr_fixed <- result[["sdr_fixed"]] + + # log(R0) + fims_logR0 <- sdr_fixed[36, "Estimate"] + # expect_lte(abs(fims_logR0 - log(om_input[["R0"]])) / log(om_input[["R0"]]), 0.0001) + expect_equal(fims_logR0, log(om_input_list[[iter_id]][["R0"]])) + + # recruitment likelihood + # log_devs is of length nyr-1 + rec_nll <- -sum(dnorm( + om_input_list[[iter_id]][["logR.resid"]][-1], rep(0, om_input_list[[iter_id]][["nyr"]] - 1), + om_input_list[[iter_id]][["logR_sd"]], TRUE + )) + + # catch and survey index expected likelihoods + index_nll_fleet <- -sum(dlnorm( + em_input_list[[iter_id]][["L.obs"]][["fleet1"]], + log(om_output_list[[iter_id]][["L.mt"]][["fleet1"]]), + sqrt(log(em_input_list[[iter_id]][["cv.L"]][["fleet1"]]^2 + 1)), TRUE + )) + index_nll_survey <- -sum(dlnorm( + em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]], + log(om_output_list[[iter_id]][["survey_index_biomass"]][["survey1"]]), + sqrt(log(em_input_list[[iter_id]][["cv.survey"]][["survey1"]]^2 + 1)), TRUE + )) + index_nll <- index_nll_fleet + index_nll_survey + # age comp likelihoods + fishing_acomp_observed <- em_input_list[[iter_id]][["L.age.obs"]][["fleet1"]] + fishing_acomp_expected <- om_output_list[[iter_id]][["L.age"]][["fleet1"]] / rowSums(om_output_list[[iter_id]][["L.age"]][["fleet1"]]) + survey_acomp_observed <- em_input_list[[iter_id]][["survey.age.obs"]][["survey1"]] + survey_acomp_expected <- om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]] / rowSums(om_output_list[[iter_id]][["survey_age_comp"]][["survey1"]]) + age_comp_nll_fleet <- age_comp_nll_survey <- 0 + for (y in 1:om_input_list[[iter_id]][["nyr"]]) { + age_comp_nll_fleet <- age_comp_nll_fleet - + dmultinom( + fishing_acomp_observed[y, ] * em_input_list[[iter_id]][["n.L"]][["fleet1"]], em_input_list[[iter_id]][["n.L"]][["fleet1"]], + fishing_acomp_expected[y, ], TRUE + ) + + age_comp_nll_survey <- age_comp_nll_survey - + dmultinom( + survey_acomp_observed[y, ] * em_input_list[[iter_id]][["n.survey"]][["survey1"]], em_input_list[[iter_id]][["n.survey"]][["survey1"]], + survey_acomp_expected[y, ], TRUE + ) + } + age_comp_nll <- age_comp_nll_fleet + age_comp_nll_survey + + # length comp likelihoods + # TODO: the commented-out code below is not working yet + # fishing_lengthcomp_observed <- em_input_list[[iter_id]][["L.length.obs"]][["fleet1"]] + # fishing_lengthcomp_expected <- om_output_list[[iter_id]][["L.length"]][["fleet1"]] / rowSums(om_output_list[[iter_id]][["L.length"]][["fleet1"]]) + # survey_lengthcomp_observed <- em_input_list[[iter_id]][["survey.length.obs"]][["survey1"]] + # survey_lengthcomp_expected <- om_output_list[[iter_id]][["survey_length_comp"]][["survey1"]] / rowSums(om_output_list[[iter_id]][["survey_length_comp"]][["survey1"]]) + # lengthcomp_nll_fleet <- lengthcomp_nll_survey <- 0 + # for (y in 1:om_input_list[[iter_id]][["nyr"]]) { + # lengthcomp_nll_fleet <- lengthcomp_nll_fleet - + # dmultinom( + # fishing_lengthcomp_observed[y, ] * em_input_list[[iter_id]][["n.L.lengthcomp"]][["fleet1"]], em_input_list[[iter_id]][["n.L.lengthcomp"]][["fleet1"]], + # fishing_lengthcomp_expected[y, ], TRUE + # ) + # + # lengthcomp_nll_survey <- lengthcomp_nll_survey - + # dmultinom( + # survey_lengthcomp_observed[y, ] * em_input_list[[iter_id]][["n.survey.lengthcomp"]][["survey1"]], em_input_list[[iter_id]][["n.survey.lengthcomp"]][["survey1"]], + # survey_lengthcomp_expected[y, ], TRUE + # ) + # } + # lengthcomp_nll <- lengthcomp_nll_fleet + lengthcomp_nll_survey + # + # expected_jnll <- rec_nll + index_nll + age_comp_nll + lengthcomp_nll + jnll <- report[["jnll"]] + + expect_equal(report[["nll_components"]][1], rec_nll) + expect_equal(report[["nll_components"]][2], index_nll_fleet) + expect_equal(report[["nll_components"]][3], age_comp_nll_fleet) + # expect_equal(report[["nll_components"]][4], lengthcomp_nll_fleet) + expect_equal(report[["nll_components"]][5], index_nll_survey) + expect_equal(report[["nll_components"]][6], age_comp_nll_survey) + # expect_equal(report[["nll_components"]][7], lengthcomp_nll_survey) + # expect_equal(report[["jnll"]], expected_jnll) +}) + +test_that("estimation test of fims", { + + result <- setup_and_run_FIMS_without_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = TRUE + ) + + # Compare FIMS results with model comparison project OM values + validate_fims( + report = result[["report"]], + sdr = result[["sdr"]], + sdr_report = result[["sdr_report"]], + om_input = om_input_list[[iter_id]], + om_output = om_output_list[[iter_id]], + em_input = em_input_list[[iter_id]] + ) +}) + +test_that("run FIMS with missing values", { + + # Define the NA (missing value) placeholder and the index where it will be inserted + na_value <- -999 + na_index <- 2 + + # Introduce a missing value into the survey observations for the estimation model input + em_input_list[[iter_id]][["surveyB.obs"]][["survey1"]][na_index] <- na_value + + # Run the FIMS setup and execution function + result <- setup_and_run_FIMS_without_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = TRUE + ) + + # Validate that the result report is not null + expect_false(is.null(result[["report"]])) + + # Obtain the gradient and Hessian matrix + g <- as.numeric(result[["obj"]][["gr"]](result[["opt"]][["par"]])) + h <- optimHess(result[["opt"]][["par"]], fn = result[["obj"]][["fn"]], gr = result[["obj"]][["gr"]]) + result[["opt"]][["par"]] <- result[["opt"]][["par"]] - solve(h, g) + + # Obtain the maximum absolute gradient to check convergence + # Ensure that the maximum gradient is less than or equal to + # the specified tolerance (0.0001) + max_gradient <- max(abs(result[["obj"]][["gr"]](result[["opt"]][["par"]]))) + expect_lte(max_gradient, 0.0001) +}) + +test_that("agecomp in proportion works", { + + # Store the original values of the number of landings observations and + # survey observations + n.L_original <- om_input_list[[iter_id]][["n.L"]][["fleet1"]] + n.survey_original <- om_input_list[[iter_id]][["n.survey"]][["survey1"]] + + # Set the number of landings observations and survey observations to 1 + om_input_list[[iter_id]][["n.L"]][["fleet1"]] <- 1 + om_input_list[[iter_id]][["n.survey"]][["survey1"]] <- 1 + on.exit(om_input_list[[iter_id]][["n.L"]][["fleet1"]] <- n.L_original, add = TRUE) + on.exit(om_input_list[[iter_id]][["n.survey"]][["survey1"]] <- n.survey_original, add = TRUE) + + # Run the FIMS setup and execution function + result <- setup_and_run_FIMS_without_wrappers( + iter_id = iter_id, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = TRUE + ) + + # Compare FIMS results with model comparison project OM values + validate_fims( + report = result[["report"]], + sdr = TMB::sdreport(result[["obj"]]), + sdr_report = result[["sdr_report"]], + om_input = om_input_list[[iter_id]], + om_output = om_output_list[[iter_id]], + em_input = em_input_list[[iter_id]] + ) +}) diff --git a/tests/testthat/test-integration-fims-estimation.R b/tests/testthat/test-integration-fims-estimation.R deleted file mode 100644 index 6a17091aa..000000000 --- a/tests/testthat/test-integration-fims-estimation.R +++ /dev/null @@ -1,325 +0,0 @@ -load(test_path("fixtures", "integration_test_data.RData")) - -test_that("deterministic test of fims", { - iter_id <- 1 - result <- setup_and_run_FIMS( - iter_id = iter_id, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = FALSE - ) - - # Set up TMB's computational graph - obj <- result$obj - - # Calculate standard errors - sdr <- TMB::sdreport(obj) - sdr_fixed <- result$sdr_fixed - - # Call report using deterministic parameter values - # obj$report() requires parameter list to avoid errors - report <- obj$report(obj$par) - - # Compare log(R0) to true value - fims_logR0 <- sdr_fixed[1, "Estimate"] - expect_gt(fims_logR0, 0.0) - expect_equal(fims_logR0, log(om_input_list[[iter_id]]$R0)) - - # Compare numbers at age to true value - for (i in 1:length(c(t(om_output_list[[iter_id]]$N.age)))) { - expect_equal(report$naa[[1]][i], c(t(om_output_list[[iter_id]]$N.age))[i]) - } - - # Compare biomass to true value - for (i in 1:length(om_output_list[[iter_id]]$biomass.mt)) { - expect_equal(report$biomass[[1]][i], om_output_list[[iter_id]]$biomass.mt[i]) - } - - # Compare spawning biomass to true value - for (i in 1:length(om_output_list[[iter_id]]$SSB)) { - expect_equal(report$ssb[[1]][i], om_output_list[[iter_id]]$SSB[i]) - } - - # Compare recruitment to true value - fims_naa <- matrix(report$naa[[1]][1:(om_input_list[[iter_id]]$nyr * om_input_list[[iter_id]]$nages)], - nrow = om_input_list[[iter_id]]$nyr, byrow = TRUE - ) - - # loop over years to compare recruitment by year - for (i in 1:om_input_list[[iter_id]]$nyr) { - expect_equal(fims_naa[i, 1], om_output_list[[iter_id]]$N.age[i, 1]) - } - - # confirm that recruitment matches the numbers in the first age - # by comparing to fims_naa (what's reported from FIMS) - expect_equal( - fims_naa[1:om_input_list[[iter_id]]$nyr, 1], - report$recruitment[[1]][1:om_input_list[[iter_id]]$nyr] - ) - - # confirm that recruitment matches the numbers in the first age - # by comparing to the true values from the OM - for (i in 1:om_input_list[[iter_id]]$nyr) { - expect_equal(report$recruitment[[1]][i], om_output_list[[iter_id]]$N.age[i, 1]) - } - - # recruitment log_devs (fixed at initial "true" values) - # the initial value of om_input$logR.resid is dropped from the model - expect_equal(report$log_recruit_dev[[1]], om_input_list[[iter_id]]$logR.resid[-1]) - - # F (fixed at initial "true" values) - expect_equal(report$F_mort[[1]], om_output_list[[iter_id]]$f) - - # Expected catch - fims_index <- report$exp_index - for (i in 1:length(om_output_list[[iter_id]]$L.mt$fleet1)) { - expect_equal(fims_index[[1]][i], om_output_list[[iter_id]]$L.mt$fleet1[i]) - } - - # Expect small relative error for deterministic test - fims_object_are <- rep(0, length(em_input_list[[iter_id]]$L.obs$fleet1)) - for (i in 1:length(em_input_list[[iter_id]]$L.obs$fleet1)) { - fims_object_are[i] <- abs(fims_index[[1]][i] - em_input_list[[iter_id]]$L.obs$fleet1[i]) / em_input_list[[iter_id]]$L.obs$fleet1[i] - } - - # Expect 95% of relative error to be within 2*cv - expect_lte(sum(fims_object_are > om_input_list[[iter_id]]$cv.L$fleet1 * 2.0), length(em_input_list[[iter_id]]$L.obs$fleet1) * 0.05) - - # Compare expected catch number at age to true values - for (i in 1:length(c(t(om_output_list[[iter_id]]$L.age$fleet1)))) { - expect_equal(report$cnaa[[1]][i], c(t(om_output_list[[iter_id]]$L.age$fleet1))[i]) - } - - # Expected catch number at age in proportion - # QUESTION: Isn't this redundant with the non-proportion test above? - fims_cnaa <- matrix(report$cnaa[[1]][1:(om_input_list[[iter_id]]$nyr * om_input_list[[iter_id]]$nages)], - nrow = om_input_list[[iter_id]]$nyr, byrow = TRUE - ) - fims_cnaa_proportion <- fims_cnaa / rowSums(fims_cnaa) - om_cnaa_proportion <- om_output_list[[iter_id]]$L.age$fleet1 / rowSums(om_output_list[[iter_id]]$L.age$fleet1) - - for (i in 1:length(c(t(om_cnaa_proportion)))) { - expect_equal(c(t(fims_cnaa_proportion))[i], c(t(om_cnaa_proportion))[i]) - } - - # Expected survey index. - # Using [[2]] because the survey is the 2nd fleet. - cwaa <- matrix(report$cwaa[[2]][1:(om_input_list[[iter_id]]$nyr * om_input_list[[iter_id]]$nages)], - nrow = om_input_list[[iter_id]]$nyr, byrow = TRUE - ) - expect_equal(fims_index[[2]], apply(cwaa, 1, sum) * om_output_list[[iter_id]]$survey_q$survey1) - - for (i in 1:length(om_output_list[[iter_id]]$survey_index_biomass$survey1)) { - expect_equal(fims_index[[2]][i], om_output_list[[iter_id]]$survey_index_biomass$survey1[i]) - } - - fims_object_are <- rep(0, length(em_input_list[[iter_id]]$surveyB.obs$survey1)) - for (i in 1:length(em_input_list[[iter_id]]$survey.obs$survey1)) { - fims_object_are[i] <- abs(fims_index[[2]][i] - em_input_list[[iter_id]]$surveyB.obs$survey1[i]) / em_input_list[[iter_id]]$surveyB.obs$survey1[i] - } - # Expect 95% of relative error to be within 2*cv - expect_lte( - sum(fims_object_are > om_input_list[[iter_id]]$cv.survey$survey1 * 2.0), - length(em_input_list[[iter_id]]$surveyB.obs$survey1) * 0.05 - ) - - # Expected catch number at age in proportion - fims_cnaa <- matrix(report$cnaa[[2]][1:(om_input_list[[iter_id]]$nyr * om_input_list[[iter_id]]$nages)], - nrow = om_input_list[[iter_id]]$nyr, byrow = TRUE - ) - - for (i in 1:length(c(t(om_output_list[[iter_id]]$survey_age_comp$survey1)))) { - expect_equal(report$cnaa[[2]][i], c(t(om_output_list[[iter_id]]$survey_age_comp$survey1))[i]) - } - - fims_cnaa_proportion <- fims_cnaa / rowSums(fims_cnaa) - om_cnaa_proportion <- om_output_list[[iter_id]]$survey_age_comp$survey1 / rowSums(om_output_list[[iter_id]]$survey_age_comp$survey1) - - for (i in 1:length(c(t(om_cnaa_proportion)))) { - expect_equal(c(t(fims_cnaa_proportion))[i], c(t(om_cnaa_proportion))[i]) - } -}) - -test_that("nll test of fims", { - iter_id <- 1 - - result <- setup_and_run_FIMS( - iter_id = iter_id, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = FALSE - ) - - parameters <- result$parameters - par_list <- 1:length(parameters[[1]]) - par_list[2:length(par_list)] <- NA - map <- list(p = factor(par_list)) - - result <- setup_and_run_FIMS( - iter_id = iter_id, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = FALSE, - map = map - ) - - # Set up TMB's computational graph - obj <- result$obj - report <- result$report - - # Calculate standard errors - sdr <- TMB::sdreport(obj) - sdr_fixed <- result$sdr_fixed - - # log(R0) - fims_logR0 <- sdr_fixed[1, "Estimate"] - # expect_lte(abs(fims_logR0 - log(om_input$R0)) / log(om_input$R0), 0.0001) - expect_equal(fims_logR0, log(om_input_list[[iter_id]]$R0)) - - # Call report using deterministic parameter values - # obj$report() requires parameter list to avoid errors - report <- obj$report(obj$par) - obj <- TMB::MakeADFun(data = list(), parameters, DLL = "FIMS", map = map) - jnll <- obj$fn() - - # recruitment likelihood - # log_devs is of length nyr-1 - rec_nll <- -sum(dnorm( - om_input_list[[iter_id]]$logR.resid[-1], rep(0, om_input_list[[iter_id]]$nyr - 1), - om_input_list[[iter_id]]$logR_sd, TRUE - )) - - # catch and survey index expected likelihoods - index_nll_fleet <- -sum(dnorm( - log(em_input_list[[iter_id]]$L.obs$fleet1), - log(om_output_list[[iter_id]]$L.mt$fleet1), - sqrt(log(em_input_list[[iter_id]]$cv.L$fleet1^2 + 1)), TRUE - )) - index_nll_survey <- -sum(dnorm( - log(em_input_list[[iter_id]]$surveyB.obs$survey1), - log(om_output_list[[iter_id]]$survey_index_biomass$survey1), - sqrt(log(em_input_list[[iter_id]]$cv.survey$survey1^2 + 1)), TRUE - )) - index_nll <- index_nll_fleet + index_nll_survey - # age comp likelihoods - fishing_acomp_observed <- em_input_list[[iter_id]]$L.age.obs$fleet1 - fishing_acomp_expected <- om_output_list[[iter_id]]$L.age$fleet1 / rowSums(om_output_list[[iter_id]]$L.age$fleet1) - survey_acomp_observed <- em_input_list[[iter_id]]$survey.age.obs$survey1 - survey_acomp_expected <- om_output_list[[iter_id]]$survey_age_comp$survey1 / rowSums(om_output_list[[iter_id]]$survey_age_comp$survey1) - age_comp_nll_fleet <- age_comp_nll_survey <- 0 - for (y in 1:om_input_list[[iter_id]]$nyr) { - age_comp_nll_fleet <- age_comp_nll_fleet - - dmultinom( - fishing_acomp_observed[y, ] * em_input_list[[iter_id]]$n.L$fleet1, em_input_list[[iter_id]]$n.L$fleet1, - fishing_acomp_expected[y, ], TRUE - ) - - age_comp_nll_survey <- age_comp_nll_survey - - dmultinom( - survey_acomp_observed[y, ] * em_input_list[[iter_id]]$n.survey$survey1, em_input_list[[iter_id]]$n.survey$survey1, - survey_acomp_expected[y, ], TRUE - ) - } - age_comp_nll <- age_comp_nll_fleet + age_comp_nll_survey - expected_jnll <- rec_nll + index_nll + age_comp_nll - - expect_equal(report$rec_nll, rec_nll) - expect_equal(report$age_comp_nll, age_comp_nll) - expect_equal(report$index_nll, index_nll) - expect_equal(jnll, expected_jnll) -}) - -test_that("estimation test of fims", { - # Initialize the iteration identifier and run FIMS with the 1st set of OM values - iter_id <- 1 - result <- setup_and_run_FIMS( - iter_id = iter_id, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = TRUE - ) - - # Compare FIMS results with model comparison project OM values - validate_fims( - report = result$report, - sdr = TMB::sdreport(result$obj), - sdr_report = result$sdr_report, - om_input = om_input_list[[iter_id]], - om_output = om_output_list[[iter_id]], - em_input = em_input_list[[iter_id]] - ) -}) - -test_that("run FIMS with missing values", { - # Initialize the iteration identifier - iter_id <- 1 - - # Define the NA (missing value) placeholder and the index where it will be inserted - na_value <- -999 - na_index <- 2 - - # Introduce a missing value into the survey observations for the estimation model input - em_input_list[[iter_id]]$surveyB.obs$survey1[na_index] <- na_value - - # Run the FIMS setup and execution function - result <- setup_and_run_FIMS( - iter_id = iter_id, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = TRUE - ) - - # Validate that the result report is not null - expect_false(is.null(result$report)) - - # Obtain the gradient and Hessian matrix - g <- as.numeric(result$obj$gr(result$opt$par)) - h <- optimHess(result$opt$par, fn = result$obj$fn, gr = result$obj$gr) - result$opt$par <- result$opt$par - solve(h, g) - - # Obtain the maximum absolute gradient to check convergence - # Ensure that the maximum gradient is less than or equal to - # the specified tolerance (0.0001) - max_gradient <- max(abs(result$obj$gr(result$opt$par))) - expect_lte(max_gradient, 0.0001) -}) - -test_that("agecomp in proportion works", { - # Initialize the iteration identifier - iter_id <- 1 - - # Store the original values of the number of landings observations and - # survey observations - n.L_original <- om_input_list[[iter_id]]$n.L$fleet1 - n.survey_original <- om_input_list[[iter_id]]$n.survey$survey1 - - # Set the number of landings observations and survey observations to 1 - om_input_list[[iter_id]]$n.L$fleet1 <- 1 - om_input_list[[iter_id]]$n.survey$survey1 <- 1 - on.exit(om_input_list[[iter_id]]$n.L$fleet1 <- n.L_original, add = TRUE) - on.exit(om_input_list[[iter_id]]$n.survey$survey1 <- n.survey_original, add = TRUE) - - # Run the FIMS setup and execution function - result <- setup_and_run_FIMS( - iter_id = iter_id, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = TRUE - ) - - # Compare FIMS results with model comparison project OM values - validate_fims( - report = result$report, - sdr = TMB::sdreport(result$obj), - sdr_report = result$sdr_report, - om_input = om_input_list[[iter_id]], - om_output = om_output_list[[iter_id]], - em_input = em_input_list[[iter_id]] - ) -}) diff --git a/tests/testthat/test-parallel-with-snowfall-with-wrappers.R b/tests/testthat/test-parallel-with-snowfall-with-wrappers.R new file mode 100644 index 000000000..198d0ba04 --- /dev/null +++ b/tests/testthat/test-parallel-with-snowfall-with-wrappers.R @@ -0,0 +1,76 @@ +# Ensure the latest precompiled version of FIMS is installed in R before +# running devtools. To do this, either run: +# - devtools::install() followed by devtools::test(), or +# - devtools::check() + +# Run FIMS in serial and parallel +# This test demonstrates how to run the FIMS model in both serial and parallel +# modes. The parallel execution uses {snowfall} to parallelize the tasks across +# multiple CPU cores. + +# Load the model comparison operating model data from the fixtures folder +load(test_path("fixtures", "integration_test_data.RData")) + +sim_num <- 10 + +# Run the FIMS model in serial and record the execution time +estimation_results_serial <- vector(mode = "list", length = sim_num) + +for (i in 1:sim_num) { + estimation_results_serial[[i]] <- setup_and_run_FIMS_with_wrappers( + iter_id = i, + om_input_list = om_input_list, + om_output_list = om_output_list, + em_input_list = em_input_list, + estimation_mode = TRUE + ) +} + +test_that("Run FIMS in parallel using {snowfall}", { + core_num <- 2 + snowfall::sfInit(parallel = TRUE, cpus = core_num) + + snowfall::sfLibrary(FIMS) + results_parallel <- snowfall::sfLapply( + 1:sim_num, + setup_and_run_FIMS_with_wrappers, + om_input_list, + om_output_list, + em_input_list, + TRUE + ) + + snowfall::sfStop() + + # Comparison of results: + # Verify that SSB values from both runs are equivalent. + expect_setequal( + purrr::map( + results_parallel, + \(x) x@estimates[x@estimates$name == "SSB", "value"] + ), + purrr::map( + estimation_results_serial, + \(x) x@estimates[x@estimates$name == "SSB", "value"] + ) + ) + + # Verify that parameter values from both runs are equivalent. + expect_setequal( + purrr::map( + results_parallel, + \(x) x@estimates[x@estimates$name == "p", "value"] + ), + purrr::map( + estimation_results_serial, + \(x) x@estimates[x@estimates$name == "p", "value"] + ) + ) + + # Verify that total NLL values from both runs are equivalent. + expect_equal( + purrr::map(results_parallel, \(x) x@report[["jnll"]]), + purrr::map(estimation_results_serial, \(x) x@report[["jnll"]]) + ) + +}) diff --git a/tests/testthat/test-parallel-with-snowfall.R b/tests/testthat/test-parallel-with-snowfall.R deleted file mode 100644 index f4098d6fe..000000000 --- a/tests/testthat/test-parallel-with-snowfall.R +++ /dev/null @@ -1,75 +0,0 @@ -# Ensure the latest precompiled version of FIMS is installed in R before -# running devtools. To do this, either run: -# - devtools::install() followed by devtools::test(), or -# - devtools::check() - -# Run FIMS in serial and parallel -# This test demonstrates how to run the FIMS model in both serial and parallel -# modes. The test compares the execution time and results of running the model -# in serial versus parallel. The parallel execution uses the {snowfall} package -# to parallelize the tasks across multiple CPU cores - -# Load the model comparison operating model data from the fixtures folder -load(test_path("fixtures", "integration_test_data.RData")) - -# Run the FIMS model in serial and record the execution time -estimation_results_serial <- vector(mode = "list", length = length(om_input_list)) - -start_time_serial <- Sys.time() -for (i in 1:length(om_input_list)) { - estimation_results_serial[[i]] <- setup_and_run_FIMS( - iter_id = i, - om_input_list = om_input_list, - om_output_list = om_output_list, - em_input_list = em_input_list, - estimation_mode = TRUE - ) -} -end_time_serial <- Sys.time() -estimation_time_serial <- end_time_serial - start_time_serial - -test_that("Run FIMS in parallel using {snowfall}", { - core_num <- parallel::detectCores() - 1 - snowfall::sfInit(parallel = TRUE, cpus = core_num) - start_time_parallel <- Sys.time() - - results_parallel <- snowfall::sfLapply( - 1:length(om_input_list), - setup_and_run_FIMS, - om_input_list, - om_output_list, - em_input_list, - TRUE - ) - - end_time_parallel <- Sys.time() - - time_parallel <- end_time_parallel - start_time_parallel - - snowfall::sfStop() - - # Compare execution times: verify that the execution time of the parallel run - # is less than the serial run. - expect_lt(object = time_parallel, expected = estimation_time_serial) - - # Compare parameters in results: - # Verify that the results from both runs are equivalent. - expect_setequal( - unname(unlist(lapply(results_parallel, `[[`, "parameters"))), - unname(unlist(lapply(estimation_results_serial, `[[`, "parameters"))) - ) - - # Compare sdr_fixed values in results: - # Verify that the results from both runs are equivalent. - expect_setequal( - unlist(lapply(results_parallel, `[[`, "sdr_fixed")), - unlist(lapply(estimation_results_serial, `[[`, "sdr_fixed")) - ) - - # Compare sdr_report values in results: - # Verify that the results from both runs are equivalent. - expect_setequal( - unlist(lapply(results_parallel, `[[`, "sdr_report")), - unlist(lapply(estimation_results_serial, `[[`, "sdr_report")) - ) -}) diff --git a/tests/testthat/test-rcpp-distributions.R b/tests/testthat/test-rcpp-distributions.R new file mode 100644 index 000000000..d9aa58ac9 --- /dev/null +++ b/tests/testthat/test-rcpp-distributions.R @@ -0,0 +1,150 @@ +test_that("normal_lpdf", { + ## several important cases to test depending on the dimensions + ## of the inputs + + ## Single value, e.g. a prior on a parameter + # generate data using R stats::rnorm + set.seed(123) + + # simulate normal data with scalar input + y <- stats::rnorm(1) + # create a fims Rcpp object + # initialize the Dnorm module + dnorm_ <- methods::new(DnormDistribution) + # populate class members + dnorm_$x <- methods::new(ParameterVector, y, 1) + dnorm_$expected_values <- methods::new(ParameterVector, 0, 1) + dnorm_$log_sd <- methods::new(ParameterVector, log(1), 1) + # evaluate the density and compare with R + expect_equal(dnorm_$evaluate(), stats::dnorm(y, 0, 1, TRUE)) + clear() + + ## A vector of state variables, but scalar arguments, e.g., a + ## random effect vector + # simulate normal data + y <- stats::rnorm(10) + # create a fims Rcpp object + # initialize the Dnorm module + dnorm_ <- methods::new(DnormDistribution) + # populate class members + dnorm_$x <- methods::new(ParameterVector, y, 10) + dnorm_$expected_values <- methods::new(ParameterVector, 0, 1) + dnorm_$log_sd <- methods::new(ParameterVector, log(1), 1) + # evaluate the density and compare with R + expect_equal(dnorm_$evaluate(), sum(stats::dnorm(y, 0, 1, TRUE))) + clear() + + ## Vectors of state variables (x) and arguments, e.g., a + ## index likelihood vector + # simulate normal data + y <- stats::rnorm(10) + # create a fims Rcpp object + # initialize the Dnorm module + dnorm_ <- methods::new(DnormDistribution) + # populate class members + dnorm_$x <- methods::new(ParameterVector, y, 10) + dnorm_$expected_values <- methods::new(ParameterVector, rep(0, 10), 10) + dnorm_$log_sd <- methods::new(ParameterVector, rep(log(1), 10), 10) + # evaluate the density and compare with R + expect_equal(dnorm_$evaluate(), sum(stats::dnorm(y, 0, 1, TRUE))) + clear() + + ## It should error out when there is a dimension mismatch + # comment out until error checking is fixed + # y <- stats::rnorm(10) + # # create a fims Rcpp object + # # initialize the Dnorm module + # dnorm_ <- methods::new(DnormDistribution) + # # populate class members + # dnorm_$x <- methods::new(FIMS:::ParameterVector, y, 10) + # dnorm_$expected_values <- methods::new(FIMS:::ParameterVector, 0, 11) + # dnorm_$log_sd <- methods::new(FIMS:::ParameterVector, log(1), 3) + # clear() +}) + +test_that("lognormal_lpdf", { + ## several important cases to test depending on the dimensions + ## of the inputs + + ## Single value, e.g. a prior on a parameter + # generate data using R stats::rlnorm + set.seed(123) + # simulate lognormal data + y <- stats::rlnorm(n = 1, meanlog = 0, sdlog = 1) + + # create a fims Rcpp object + # initialize the Dlnorm module + dlnorm_ <- methods::new(DlnormDistribution) + # populate class members + dlnorm_$x <- methods::new(ParameterVector, y, 1) + dlnorm_$expected_values <- methods::new(ParameterVector, 0, 1) + dlnorm_$log_sd <- methods::new(ParameterVector, log(1), 1) + # evaluate the density and compare with R + expect_equal(dlnorm_$evaluate(), stats::dlnorm(y, 0, 1, TRUE) + log(y)) + clear() + + ## A vector of state variables, but scalar arguments, e.g., a + ## random effect vector + y <- stats::rlnorm(n = 10, meanlog = 0, sdlog = 1) + + # create a fims Rcpp object + # initialize the Dlnorm module + dlnorm_ <- methods::new(DlnormDistribution) + # populate class members + dlnorm_$x <- methods::new(ParameterVector, y, 10) + dlnorm_$expected_values <- methods::new(ParameterVector, 0, 1) + dlnorm_$log_sd <- methods::new(ParameterVector, log(1), 1) + # evaluate the density and compare with R + expect_equal(dlnorm_$evaluate(), sum(stats::dlnorm(y, 0, 1, TRUE)) + sum(log(y))) + clear() + + + ## Vectors of state variables (x) and arguments, e.g., a + ## index likelihood vector + y <- stats::rlnorm(n = 10, meanlog = 0, sdlog = 1) + + # create a fims Rcpp object + # initialize the Dlnorm module + dlnorm_ <- methods::new(DlnormDistribution) + # populate class members + dlnorm_$x <- methods::new(ParameterVector, y, 10) + dlnorm_$expected_values <- methods::new(ParameterVector, rep(0, 10), 10) + dlnorm_$log_sd <- methods::new(ParameterVector, rep(log(1), 10), 10) + # evaluate the density and compare with R + expect_equal(dlnorm_$evaluate(), sum(stats::dlnorm(y, 0, 1, TRUE)) + sum(log(y))) + clear() + + ## It should error out when there is a dimension mismatch + # comment out until error checking is fixed + # y <- stats::rlnorm(n = 10, meanlog = 0, sdlog = 1) + # + # # create a fims Rcpp object + # # initialize the Dlnorm module + # dlnorm_ <- methods::new(DlnormDistribution) + # # populate class members + # dlnorm_$x <- methods::new(ParameterVector, y, 10) + # dlnorm_$expected_values <- methods::new(ParameterVector, 0, 11) + # dlnorm_$log_sd <- methods::new(ParameterVector, log(1), 3) + # clear() +}) + +test_that("multinomial_lpdf", { + # generate data using R stats:rnorm + set.seed(123) + p <- (1:10) / sum(1:10) + x <- t(stats::rmultinom(1, 100, p)) + # create a fims Rcpp object + # initialize the Dmultinom module + dmultinom_ <- methods::new(DmultinomDistribution) + # populate class members + dmultinom_$expected_values <- methods::new(ParameterVector, p, 10) + dmultinom_$dims <- c(1, 10) + dmultinom_$x <- methods::new(ParameterVector, as.vector(x), 10) + # evaluate the density and compare with R + expect_equal( + dmultinom_$evaluate(), + stats::dmultinom(x = x, prob = p, log = TRUE) + ) + + clear() +}) diff --git a/tests/testthat/test-rcpp-ewaa.r b/tests/testthat/test-rcpp-ewaa.r index bd5e1178d..099bf5ad1 100644 --- a/tests/testthat/test-rcpp-ewaa.r +++ b/tests/testthat/test-rcpp-ewaa.r @@ -1,13 +1,13 @@ -data(package = "FIMS") +data("data1", package = "FIMS") test_that("ewaa data can be added to model", { - ewaa_growth <- new(EWAAgrowth) - fims_frame <- FIMSFrame(data_mile1) - ewaa_growth$ages <- m_ages(fims_frame) + ewaa_growth <- methods::new(EWAAgrowth) + fims_frame <- FIMSFrame(data1) + ewaa_growth$ages <- get_ages(fims_frame) ewaa_growth$weights <- m_weight_at_age(fims_frame) expect_equal(ewaa_growth$evaluate(1), 0.00053065552) - ewaa_growth2 <- new(EWAAgrowth) + ewaa_growth2 <- methods::new(EWAAgrowth) ewaa_growth2$ages <- c(ewaa_growth$ages, 12) ewaa_growth2$weights <- m_weight_at_age(fims_frame) expect_error( diff --git a/tests/testthat/test-rcpp-fims.R b/tests/testthat/test-rcpp-fims.R index 58cd924a8..b629b9049 100644 --- a/tests/testthat/test-rcpp-fims.R +++ b/tests/testthat/test-rcpp-fims.R @@ -1,12 +1,12 @@ test_that("Rcpp interface works for modules", { - expect_no_error(parameter <- new(Parameter, .1)) - expect_no_error(beverton_holt <- new(BevertonHoltRecruitment)) - expect_no_error(logistic_selectivity <- new(LogisticSelectivity)) - expect_no_error(ewaa_growth <- new(EWAAgrowth)) - logistic_selectivity$slope$value <- .7 - logistic_selectivity$inflection_point$value <- 5.0 + expect_no_error(parameter <- methods::new(Parameter, .1)) + expect_no_error(beverton_holt <- methods::new(BevertonHoltRecruitment)) + expect_no_error(logistic_selectivity <- methods::new(LogisticSelectivity)) + expect_no_error(ewaa_growth <- methods::new(EWAAgrowth)) + logistic_selectivity$slope[1]$value <- .7 + logistic_selectivity$inflection_point[1]$value <- 5.0 - expect_equal(logistic_selectivity$slope$value, 0.7) + expect_equal(logistic_selectivity$slope[1]$value, 0.7) expect_equal(logistic_selectivity$get_id(), 1) ewaa_growth$ages <- 1.0 ewaa_growth$weights <- 2.5 diff --git a/tests/testthat/test-rcpp-fleet-interface.R b/tests/testthat/test-rcpp-fleet-interface.R index 637b29a85..24da27fc4 100644 --- a/tests/testthat/test-rcpp-fleet-interface.R +++ b/tests/testthat/test-rcpp-fleet-interface.R @@ -1,16 +1,16 @@ test_that("Fleet: selectivity IDs can be added to the fleet module", { # Create selectivity for fleet 1 - selectivity_fleet1 <- new(LogisticSelectivity) + selectivity_fleet1 <- methods::new(LogisticSelectivity) expect_equal((selectivity_fleet1$get_id()), 1) # Create selectivity for fleet 2 - selectivity_fleet2 <- new(LogisticSelectivity) + selectivity_fleet2 <- methods::new(LogisticSelectivity) expect_equal((selectivity_fleet2$get_id()), 2) # Add selectivity to fleet - fleet1 <- new(Fleet) - fleet2 <- new(Fleet) + fleet1 <- methods::new(Fleet) + fleet2 <- methods::new(Fleet) # Expect code produces no output, error, message, or warnings expect_silent(fleet1$SetSelectivity(selectivity_fleet1$get_id())) @@ -22,35 +22,16 @@ fleet module", { clear() }) - -test_that("Fleet: SetAgeCompLikelihood works", { - fleet <- new(Fleet) - - expect_silent(fleet$SetAgeCompLikelihood(1)) - - clear() -}) - -test_that("Fleet: SetIndexLikelihood works", { - fleet <- new(Fleet) - - expect_silent(fleet$SetIndexLikelihood(1)) - - clear() -}) - test_that("Fleet: SetObservedAgeCompData works", { - fleet <- new(Fleet) - + fleet <- methods::new(Fleet) expect_silent(fleet$SetObservedAgeCompData(1)) - + expect_equal(fleet$GetObservedAgeCompDataID(), 1) clear() }) test_that("Fleet: SetObservedIndexData works", { - fleet <- new(Fleet) - + fleet <- methods::new(Fleet) expect_silent(fleet$SetObservedIndexData(1)) - + expect_equal(fleet$GetObservedIndexDataID(), 1) clear() }) diff --git a/tests/testthat/test-rcpp-get_fixed.R b/tests/testthat/test-rcpp-get_fixed.R index fc76ab2a9..b2bf38cd6 100644 --- a/tests/testthat/test-rcpp-get_fixed.R +++ b/tests/testthat/test-rcpp-get_fixed.R @@ -1,18 +1,18 @@ test_that("test get parameter vector", { # Create selectivity - selectivity <- new(LogisticSelectivity) - selectivity$inflection_point$value <- 10.0 - selectivity$inflection_point$min <- 8.0 - selectivity$inflection_point$max <- 12.0 - selectivity$inflection_point$is_random_effect <- FALSE - selectivity$inflection_point$estimated <- TRUE - selectivity$slope$value <- 0.2 - selectivity$slope$is_random_effect <- FALSE - selectivity$slope$estimated <- TRUE + selectivity <- methods::new(LogisticSelectivity) + selectivity$inflection_point[1]$value <- 10.0 + selectivity$inflection_point[1]$min <- 8.0 + selectivity$inflection_point[1]$max <- 12.0 + selectivity$inflection_point[1]$is_random_effect <- FALSE + selectivity$inflection_point[1]$estimated <- TRUE + selectivity$slope[1]$value <- 0.2 + selectivity$slope[1]$is_random_effect <- FALSE + selectivity$slope[1]$estimated <- TRUE CreateTMBModel() p <- get_fixed() - sel_parm <- c(selectivity$inflection_point$value, selectivity$slope$value) + sel_parm <- c(selectivity$inflection_point[1]$value, selectivity$slope[1]$value) expect_equal(sel_parm, p) # test fims clear @@ -28,29 +28,29 @@ test_that("test get parameter vector", { clear() p <- get_fixed() expect_equal(numeric(0), p) - selectivity <- new(LogisticSelectivity) - selectivity$inflection_point$value <- 11.0 - selectivity$inflection_point$min <- 8.0 - selectivity$inflection_point$max <- 12.0 - selectivity$inflection_point$is_random_effect <- FALSE - selectivity$inflection_point$estimated <- TRUE - selectivity$slope$value <- 0.5 - selectivity$slope$is_random_effect <- FALSE - selectivity$slope$estimated <- TRUE - sel_parm <- c(selectivity$inflection_point$value, selectivity$slope$value) - recruitment <- new(BevertonHoltRecruitment) + selectivity <- methods::new(LogisticSelectivity) + selectivity$inflection_point[1]$value <- 11.0 + selectivity$inflection_point[1]$min <- 8.0 + selectivity$inflection_point[1]$max <- 12.0 + selectivity$inflection_point[1]$is_random_effect <- FALSE + selectivity$inflection_point[1]$estimated <- TRUE + selectivity$slope[1]$value <- 0.5 + selectivity$slope[1]$is_random_effect <- FALSE + selectivity$slope[1]$estimated <- TRUE + sel_parm <- c(selectivity$inflection_point[1]$value, selectivity$slope[1]$value) + recruitment <- methods::new(BevertonHoltRecruitment) h <- 0.75 r0 <- 1000000.0 spawns <- 9.55784 * 10^6 ssb0 <- 0.0102562 - recruitment$logit_steep$value <- -log(1.0 - h) + log(h - 0.2) - recruitment$logit_steep$min <- 0.21 - recruitment$logit_steep$max <- 1.0 - recruitment$logit_steep$is_random_effect <- FALSE - recruitment$logit_steep$estimated <- TRUE - recruitment$log_rzero$value <- log(r0) - recruitment$log_rzero$is_random_effect <- FALSE - recruitment$log_rzero$estimated <- TRUE + recruitment$logit_steep[1]$value <- -log(1.0 - h) + log(h - 0.2) + recruitment$logit_steep[1]$min <- 0.21 + recruitment$logit_steep[1]$max <- 1.0 + recruitment$logit_steep[1]$is_random_effect <- FALSE + recruitment$logit_steep[1]$estimated <- TRUE + recruitment$log_rzero[1]$value <- log(r0) + recruitment$log_rzero[1]$is_random_effect <- FALSE + recruitment$log_rzero[1]$estimated <- TRUE rec_parm <- c(-log(1.0 - h) + log(h - 0.2), log(r0)) CreateTMBModel() @@ -59,3 +59,44 @@ test_that("test get parameter vector", { expect_equal(c(sel_parm, rec_parm), p2) clear() }) +test_that("get_fixed() works when estimated is set to FALSE", { + + clear() + selectivity <- methods::new(LogisticSelectivity) + selectivity$inflection_point[1]$value <- 10.0 + selectivity$inflection_point[1]$min <- 8.0 + selectivity$inflection_point[1]$max <- 12.0 + selectivity$inflection_point[1]$estimated <- FALSE + selectivity$slope[1]$value <- 0.2 + selectivity$slope[1]$estimated <- TRUE + + CreateTMBModel() + p <- get_fixed() + sel_parm <- c( + selectivity$slope[1]$value + ) + expect_equal(sel_parm, p) + + clear() + + fish_selex <- methods::new(DoubleLogisticSelectivity) + fish_selex$inflection_point_asc[1]$value <- 2 + fish_selex$inflection_point_asc[1]$estimated <- TRUE + fish_selex$inflection_point_desc[1]$value <- 3 + fish_selex$inflection_point_desc[1]$estimated <- TRUE + fish_selex$slope_asc[1]$value <- 1 + fish_selex$slope_asc[1]$estimated <- FALSE + fish_selex$slope_desc[1]$value <- 1.5 + fish_selex$slope_desc[1]$estimated <- TRUE + + CreateTMBModel() + p <- get_fixed() + sel_parm <- c( + fish_selex$inflection_point_asc[1]$value, + fish_selex$inflection_point_desc[1]$value, + fish_selex$slope_desc[1]$value + ) + expect_equal(p, sel_parm) + + clear() +}) diff --git a/tests/testthat/test-rcpp-maturity-interface.R b/tests/testthat/test-rcpp-maturity-interface.R index 4ded4336c..3904a2812 100644 --- a/tests/testthat/test-rcpp-maturity-interface.R +++ b/tests/testthat/test-rcpp-maturity-interface.R @@ -1,26 +1,26 @@ test_that("Maturity input settings work as expected", { # Create maturity1 - maturity1 <- new(LogisticMaturity) + maturity1 <- methods::new(LogisticMaturity) - maturity1$inflection_point$value <- 10.0 - maturity1$inflection_point$min <- 8.0 - maturity1$inflection_point$max <- 12.0 - maturity1$inflection_point$is_random_effect <- TRUE - maturity1$inflection_point$estimated <- TRUE - maturity1$slope$value <- 0.2 + maturity1$inflection_point[1]$value <- 10.0 + maturity1$inflection_point[1]$min <- 8.0 + maturity1$inflection_point[1]$max <- 12.0 + maturity1$inflection_point[1]$is_random_effect <- TRUE + maturity1$inflection_point[1]$estimated <- TRUE + maturity1$slope[1]$value <- 0.2 expect_equal(maturity1$get_id(), 1) - expect_equal(maturity1$inflection_point$value, 10.0) - expect_equal(maturity1$inflection_point$min, 8.0) - expect_equal(maturity1$inflection_point$max, 12.0) - expect_true(maturity1$inflection_point$is_random_effect) - expect_true(maturity1$inflection_point$estimated) - expect_equal(maturity1$slope$value, 0.2) + expect_equal(maturity1$inflection_point[1]$value, 10.0) + expect_equal(maturity1$inflection_point[1]$min, 8.0) + expect_equal(maturity1$inflection_point[1]$max, 12.0) + expect_true(maturity1$inflection_point[1]$is_random_effect) + expect_true(maturity1$inflection_point[1]$estimated) + expect_equal(maturity1$slope[1]$value, 0.2) expect_equal(maturity1$evaluate(10.0), 0.5) # Create selectivity2 - maturity2 <- new(LogisticMaturity) + maturity2 <- methods::new(LogisticMaturity) expect_equal((maturity2$get_id()), 2) clear() diff --git a/tests/testthat/test-rcpp-population-interface.R b/tests/testthat/test-rcpp-population-interface.R index d786dd21d..5cdc1b04d 100644 --- a/tests/testthat/test-rcpp-population-interface.R +++ b/tests/testthat/test-rcpp-population-interface.R @@ -1,27 +1,26 @@ -library(testthat) -test_that("Population input settings work as expected", { - population <- new(Population) - nyears <- 10 - nages <- 10 - population$log_M <- rep(-1, nyears * nages) - population$estimate_M <- FALSE - population$log_init_naa <- log(rep(1, nages)) - population$estimate_init_naa <- TRUE - population$nages <- nages - population$ages <- 1:nages - population$nfleets <- 2 - population$nseasons <- 1 - population$nyears <- nyears - population$proportion_female <- rep(0.5, nages) - population$estimate_prop_female <- FALSE - - expect_equal(population$get_id(), 1) - expect_equal(population$log_M, rep(-1, nyears * nages)) - expect_false(population$estimate_M) - expect_equal(population$log_init_naa, rep(0, nages)) - expect_true(population$estimate_init_naa) - expect_false(population$estimate_prop_female) - expect_equal(population$proportion_female, rep(0.5, nages)) - - clear() -}) +library(testthat) +test_that("Population input settings work as expected", { + population <- methods::new(Population) + nyears <- 10 + nages <- 10 + population$log_M <- methods::new(ParameterVector, rep(-1, nyears * nages), nyears * nages) + population$log_init_naa <- methods::new(ParameterVector, log(rep(1, nages)), nages) + population$log_init_naa$set_all_estimable(TRUE) + population$nages <- nages + population$ages <- 1:nages + population$nfleets <- 2 + population$nseasons <- 1 + population$nyears <- nyears + + expect_equal(population$get_id(), 1) + for (i in 1:(nyears * nages)) { + expect_equal(population$log_M[i]$value, -1) + expect_false(population$log_M[i]$estimated) + } + for (i in 1:nyears) { + expect_equal(population$log_init_naa[i]$value, 0) + expect_true(population$log_init_naa[i]$estimated) + } + + clear() +}) diff --git a/tests/testthat/test-rcpp-recruitment-interface.R b/tests/testthat/test-rcpp-recruitment-interface.R index 55e122b8d..2f17aaf38 100644 --- a/tests/testthat/test-rcpp-recruitment-interface.R +++ b/tests/testthat/test-rcpp-recruitment-interface.R @@ -1,44 +1,36 @@ library(testthat) test_that("Recruitment input settings work as expected", { # Create recruitment - recruitment <- new(BevertonHoltRecruitment) + recruitment <- methods::new(BevertonHoltRecruitment) h <- 0.75 r0 <- 1000000.0 spawns <- 9.55784 * 10^6 ssb0 <- 0.0102562 - - recruitment$logit_steep$value <- -log(1.0 - h) + log(h - 0.2) - recruitment$logit_steep$min <- 0.21 - recruitment$logit_steep$max <- 1.0 - recruitment$logit_steep$is_random_effect <- TRUE - recruitment$logit_steep$estimated <- TRUE - recruitment$log_rzero$value <- log(r0) - recruitment$log_sigma_recruit$value <- log(0.7) + recruitment$logit_steep[1]$value <- -log(1.0 - h) + log(h - 0.2) + recruitment$logit_steep[1]$min <- 0.21 + recruitment$logit_steep[1]$max <- 1.0 + recruitment$logit_steep[1]$is_random_effect <- TRUE + recruitment$logit_steep[1]$estimated <- TRUE + recruitment$log_rzero[1]$value <- log(r0) expect_equal(recruitment$get_id(), 1) - expect_equal(recruitment$logit_steep$value, 0.78845736) - expect_equal(recruitment$logit_steep$min, 0.21) - expect_equal(recruitment$logit_steep$max, 1.0) - expect_true(recruitment$logit_steep$is_random_effect) - expect_true(recruitment$logit_steep$estimated) - expect_equal(recruitment$log_rzero$value, log(1000000.0)) + expect_equal(recruitment$logit_steep[1]$value, 0.78845736) + expect_equal(recruitment$logit_steep[1]$min, 0.21) + expect_equal(recruitment$logit_steep[1]$max, 1.0) + expect_true(recruitment$logit_steep[1]$is_random_effect) + expect_true(recruitment$logit_steep[1]$estimated) + expect_equal(recruitment$log_rzero[1]$value, log(1000000.0)) expect_equal(object = recruitment$evaluate(spawns, ssb0), expected = 1090802.68) log_devs <- c(-1.0, 2.0, 3.0) - recruitment$log_devs <- log_devs - - - expected_nll <- -sum(log(stats::dnorm(log_devs, 0, 0.7))) + recruitment$log_devs <- methods::new(ParameterVector, log_devs, length(log_devs)) - recruitment$estimate_log_devs <- FALSE - expect_equal(recruitment$evaluate_nll(), 0.0) + expected_lpdf <- sum(log(stats::dnorm(log_devs, 0, 0.7))) - recruitment$estimate_log_devs <- TRUE - expect_equal(recruitment$evaluate_nll(), expected = expected_nll) clear() }) diff --git a/tests/testthat/test-rcpp-selectivity-interface.R b/tests/testthat/test-rcpp-selectivity-interface.R index 398fe0c9d..7e7bb7255 100644 --- a/tests/testthat/test-rcpp-selectivity-interface.R +++ b/tests/testthat/test-rcpp-selectivity-interface.R @@ -1,39 +1,39 @@ test_that("Selectivity input settings work as expected", { # Create selectivity1 - selectivity1 <- new(LogisticSelectivity) + selectivity1 <- methods::new(LogisticSelectivity) - selectivity1$inflection_point$value <- 10.0 - selectivity1$inflection_point$min <- 8.0 - selectivity1$inflection_point$max <- 12.0 - selectivity1$inflection_point$is_random_effect <- TRUE - selectivity1$inflection_point$estimated <- TRUE - selectivity1$slope$value <- 0.2 + selectivity1$inflection_point[1]$value <- 10.0 + selectivity1$inflection_point[1]$min <- 8.0 + selectivity1$inflection_point[1]$max <- 12.0 + selectivity1$inflection_point[1]$is_random_effect <- TRUE + selectivity1$inflection_point[1]$estimated <- TRUE + selectivity1$slope[1]$value <- 0.2 expect_equal(selectivity1$get_id(), 1) - expect_equal(selectivity1$inflection_point$value, 10.0) - expect_equal(selectivity1$inflection_point$min, 8.0) - expect_equal(selectivity1$inflection_point$max, 12.0) - expect_true(selectivity1$inflection_point$is_random_effect) - expect_true(selectivity1$inflection_point$estimated) - expect_equal(selectivity1$slope$value, 0.2) + expect_equal(selectivity1$inflection_point[1]$value, 10.0) + expect_equal(selectivity1$inflection_point[1]$min, 8.0) + expect_equal(selectivity1$inflection_point[1]$max, 12.0) + expect_true(selectivity1$inflection_point[1]$is_random_effect) + expect_true(selectivity1$inflection_point[1]$estimated) + expect_equal(selectivity1$slope[1]$value, 0.2) expect_equal(selectivity1$evaluate(10.0), 0.5) # Create selectivity2 - selectivity2 <- new(LogisticSelectivity) + selectivity2 <- methods::new(LogisticSelectivity) expect_equal((selectivity2$get_id()), 2) # Test double logistic - selectivity3 <- new(DoubleLogisticSelectivity) + selectivity3 <- methods::new(DoubleLogisticSelectivity) - selectivity3$inflection_point_asc$value <- 10.5 - selectivity3$slope_asc$value <- 0.2 - selectivity3$inflection_point_desc$value <- 15.0 - selectivity3$slope_desc$value <- 0.05 + selectivity3$inflection_point_asc[1]$value <- 10.5 + selectivity3$slope_asc[1]$value <- 0.2 + selectivity3$inflection_point_desc[1]$value <- 15.0 + selectivity3$slope_desc[1]$value <- 0.05 expect_equal(selectivity3$get_id(), 3) - expect_equal(selectivity3$inflection_point_asc$value, 10.5) - expect_equal(selectivity3$slope_asc$value, 0.2) + expect_equal(selectivity3$inflection_point_asc[1]$value, 10.5) + expect_equal(selectivity3$slope_asc[1]$value, 0.2) # R code that generates true value for the test # 1.0/(1.0+exp(-(34.5-10.5)*0.2)) * (1.0 - 1.0/(1.0+exp(-(34.5-15)*0.05))) = 0.2716494 expect_equal(selectivity3$evaluate(34.5), 0.2716494, tolerance = 0.0000001) diff --git a/tests/testthat/test-rcpp-tmb-distributions.R b/tests/testthat/test-rcpp-tmb-distributions.R deleted file mode 100644 index 97adea2d7..000000000 --- a/tests/testthat/test-rcpp-tmb-distributions.R +++ /dev/null @@ -1,63 +0,0 @@ -test_that("dnorm", { - # generate data using R stats:rnorm - set.seed(123) - # simulate normal data - y <- stats::rnorm(1) - - # create a fims Rcpp object - # initialize the Dnorm module - dnorm_ <- new(TMBDnormDistribution) - # populate class members - dnorm_$x$value <- y - dnorm_$mean$value <- 0 - dnorm_$sd$value <- 1 - # evaluate the density and compare with R - expect_equal(dnorm_$evaluate(TRUE), stats::dnorm(y, 0, 1, TRUE)) - - clear() -}) - -test_that("dlnorm", { - # generate data using R stats:rnorm - set.seed(123) - # simulate lognormal data - y <- stats::rlnorm(n = 1, meanlog = 0, sdlog = 1) - - # create a fims Rcpp object - # initialize the Dnorm module - dlnorm_ <- new(TMBDlnormDistribution) - # populate class members - dlnorm_$x$value <- y - dlnorm_$meanlog$value <- 0 - dlnorm_$sdlog$value <- 1 - # evaluate the density and compare with R - expect_equal(dlnorm_$evaluate(TRUE), stats::dlnorm(y, 0, 1, TRUE)) - expect_equal(dlnorm_$evaluate(FALSE), stats::dlnorm(y, 0, 1, FALSE)) - - clear() -}) - -test_that("dmultinom", { - # generate data using R stats:rnorm - set.seed(123) - p <- (1:10) / sum(1:10) - x <- stats::rmultinom(1, 100, p) - - # create a fims Rcpp object - # initialize the Dmultinom module - dmultinom_ <- new(TMBDmultinomDistribution) - # populate class members - dmultinom_$x <- x - dmultinom_$p <- p - # evaluate the density and compare with R - expect_equal( - dmultinom_$evaluate(TRUE), - stats::dmultinom(x = x, prob = p, log = TRUE) - ) - expect_equal( - dmultinom_$evaluate(FALSE), - stats::dmultinom(x = x, prob = p, log = FALSE) - ) - - clear() -}) diff --git a/tests/testthat/test-unit-rcpp-interface-variable-vector.R b/tests/testthat/test-unit-rcpp-interface-variable-vector.R new file mode 100644 index 000000000..72814ae54 --- /dev/null +++ b/tests/testthat/test-unit-rcpp-interface-variable-vector.R @@ -0,0 +1,200 @@ +test_that("Parameter vector works as expected", { + v_size <- 10 + v1_value <- 1.0 + v2_value <- 2.0 + + # Test that default constructor works + v0 <- methods::new(ParameterVector) + expect_equal(length(v0), 1) + expect_equal(v0$at(1)$value, 0) + + # Test that constructor that initializes based on size works. + v1 <- methods::new(ParameterVector, v_size) + v1$fill(v1_value) + for (i in 1:v_size) { + expect_equal(v1$get(i - 1)$value, v1_value) + } + + # Test that constructor that takes vector and size works. + v2 <- methods::new(ParameterVector, rep(v2_value, v_size), v_size) + for (i in 1:v_size) { + expect_equal(v2$get(i - 1)$value, v2_value) + } + + + # Test plus operator works. + v_plus_test <- v1 + v2 + for (i in 1:v_size) { + expect_equal(v_plus_test$get(i - 1)$value, (v1[i]$value + v2[i]$value)) + } + + + # Test minus operator works. + v_minus_test <- v1 - v2 + for (i in 1:v_size) { + expect_equal(v_minus_test$get(i - 1)$value, (v1[i]$value - v2[i]$value)) + } + + + # Test mult operator works. + v_mult_test <- v1 * v2 + for (i in 1:v_size) { + expect_equal(v_mult_test$get(i - 1)$value, (v1[i]$value * v2[i]$value)) + } + + + # Test div operator works. + v_div_test <- v1 / v2 + for (i in 1:v_size) { + expect_equal(v_div_test$get(i - 1)$value, (v1[i]$value / v2[i]$value)) + } + + + # Test pre scalar plus operator works. + v_plus_test_scalar <- v2_value + v1 + for (i in 1:v_size) { + expect_equal(v_plus_test_scalar$get(i - 1)$value, (v2_value + v1[i]$value)) + } + + + # Test pre scalar minus operator works. + v_minus_test_scalar <- v2_value - v1 + for (i in 1:v_size) { + expect_equal(v_minus_test_scalar$get(i - 1)$value, (v2_value - v1[i]$value)) + } + + + # Test pre scalar mult operator works. + v_mult_test_scalar <- v2_value * v1 + for (i in 1:v_size) { + expect_equal(v_mult_test_scalar$get(i - 1)$value, (v2_value * v1[i]$value)) + } + + + # Test pre scalar div operator works. + v_div_test_scalar <- v2_value / v1 + for (i in 1:v_size) { + expect_equal(v_div_test_scalar$get(i - 1)$value, (v2_value / v1[i]$value)) + } + + + # Test post scalar plus operator works. + v_plus_test_scalar <- v1 + v2_value + for (i in 1:v_size) { + expect_equal(v_plus_test_scalar$get(i - 1)$value, (v1[i]$value + v2_value)) + } + + + # Test post scalar minus operator works. + v_minus_test_scalar <- v1 - v2_value + for (i in 1:v_size) { + expect_equal(v_minus_test_scalar$get(i - 1)$value, (v1[i]$value - v2_value)) + } + + + # Test post scalar mult operator works. + v_mult_test_scalar <- v1 * v2_value + for (i in 1:v_size) { + expect_equal(v_mult_test_scalar$get(i - 1)$value, (v1[i]$value * v2_value)) + } + + + # Test post scalar div operator works. + v_div_test_scalar <- v1 / v2_value + for (i in 1:v_size) { + expect_equal(v_div_test_scalar$get(i - 1)$value, (v1[i]$value / v2_value)) + } + + + # Test acos function works. + v_acos_test <- acos(v1) + for (i in 1:v_size) { + expect_equal(v_acos_test$get(i - 1)$value, acos(v1_value)) + } + + + # Test asin function works. + v_asin_test <- asin(v1) + for (i in 1:v_size) { + expect_equal(v_asin_test$get(i - 1)$value, asin(v1_value)) + } + + + # Test atan function works. + v_atan_test <- atan(v1) + for (i in 1:v_size) { + expect_equal(v_atan_test$get(i - 1)$value, atan(v1_value)) + } + + + # Test cos function works. + v_cos_test <- cos(v1) + for (i in 1:v_size) { + expect_equal(v_cos_test$get(i - 1)$value, cos(v1_value)) + } + + + # Test cosh function works. + v_cosh_test <- cosh(v1) + for (i in 1:v_size) { + expect_equal(v_cosh_test$get(i - 1)$value, cosh(v1_value)) + } + + + # Test sin function works. + v_sin_test <- sin(v1) + for (i in 1:v_size) { + expect_equal(v_sin_test$get(i - 1)$value, sin(v1_value)) + } + + + # Test sinh function works. + v_sinh_test <- sinh(v1) + for (i in 1:v_size) { + expect_equal(v_sinh_test$get(i - 1)$value, sinh(v1_value)) + } + + + # Test tan function works. + v_tan_test <- tan(v1) + for (i in 1:v_size) { + expect_equal(v_tan_test$get(i - 1)$value, tan(v1_value)) + } + + + # Test tanh function works. + v_tanh_test <- tanh(v1) + for (i in 1:v_size) { + expect_equal(v_tanh_test$get(i - 1)$value, tanh(v1_value)) + } + + + # Test exp function works. + v_exp_test <- exp(v1) + for (i in 1:v_size) { + expect_equal(v_exp_test$get(i - 1)$value, exp(v1_value)) + } + + + # Test log10 function works. + v_log10_test <- log10(v1) + for (i in 1:v_size) { + expect_equal(v_log10_test$get(i - 1)$value, log10(v1_value)) + } + + + # Test sqrt function works. + v_sqrt_test <- sqrt(v1) + for (i in 1:v_size) { + expect_equal(v_sqrt_test$get(i - 1)$value, sqrt(v1_value)) + } + + + # Test log function works. + v_log_test <- log(v1) + for (i in 1:v_size) { + expect_equal(v_log_test$get(i - 1)$value, log(v1_value)) + } + + clear() +}) diff --git a/tests/testthat/test-update_parameters.R b/tests/testthat/test-update_parameters.R new file mode 100644 index 000000000..6778fa1cf --- /dev/null +++ b/tests/testthat/test-update_parameters.R @@ -0,0 +1,90 @@ +data("data1") +data <- FIMSFrame(data1) + +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution" + ) +) + +fleets = list(fleet1 = fleet1, survey1 = survey1) + +current_parameters <- create_default_parameters(data, fleets = fleets) + +modified_parameters_valid = list( + survey1 = list( + LogisticSelectivity.slope.value = 2, + Fleet.log_q.value = -14 + ) +) + +test_that("update_parameters updates parameters correctly", { + + updated_params <- update_parameters(current_parameters, modified_parameters_valid) + + # Check that parameters are updated correctly + expect_equal(updated_params$parameters$survey1$Fleet.log_q.value, -14) + expect_equal(updated_params$parameters$survey1$LogisticSelectivity.slope.value, 2) + + # Check that modules are unchanged + expect_equal(updated_params$modules, current_parameters$modules) +}) + +test_that("update_parameters handles missing parameters", { + modified_parameters_invalid <- list( + fleet_invalid = list( + LogisticSelectivity.slope.value = 2, + Fleet.log_q.value = -14 + ) + ) + + expect_error(update_parameters(current_parameters, modified_parameters_invalid)) +}) + +test_that("update_parameters detects invalid current_parameters format", { + invalid_current_parameters <- list( + parameters = list(module1 = list(param1 = 1)), + extra_field = "unexpected" + ) + + expect_error( + update_parameters(invalid_current_parameters, modified_parameters_valid), + "must be a list containing parameters and modules" + ) +}) + +test_that("update_parameters validates parameter names", { + invalid_modified_parameters <- list( + fleet1 = list(nonexistent_param = 10) + ) + + expect_error( + update_parameters(current_parameters, invalid_modified_parameters), + "does not exist in" + ) +}) + +test_that("update_parameters validates parameter length", { + invalid_modified_parameters <- list( + fleet1 = list(LogisticSelectivity.slope.value = c(2, 3)) # Mismatched length + ) + + expect_error( + update_parameters(current_parameters, invalid_modified_parameters), + "does not match between" + ) +}) + +test_that("update_parameters validates parameter types", { + invalid_modified_parameters <- list( + fleet1 = list(LogisticSelectivity.slope.value = "invalide_type") + ) + + expect_error( + update_parameters(current_parameters, invalid_modified_parameters), + "does not match between" + ) +}) + diff --git a/vignettes/.gitignore b/vignettes/.gitignore index 097b24163..b619edca4 100644 --- a/vignettes/.gitignore +++ b/vignettes/.gitignore @@ -1,2 +1,6 @@ *.html +*.md +*.pdf *.R +*/libs/ +fims-demo_files/ \ No newline at end of file diff --git a/vignettes/figures/fims-path-maturity-1.png b/vignettes/figures/fims-path-maturity-1.png index 7185f9bee..28ee00f54 100644 Binary files a/vignettes/figures/fims-path-maturity-1.png and b/vignettes/figures/fims-path-maturity-1.png differ diff --git a/vignettes/figures/fims-path-maturity-2.png b/vignettes/figures/fims-path-maturity-2.png index af3b43200..6db28eb94 100644 Binary files a/vignettes/figures/fims-path-maturity-2.png and b/vignettes/figures/fims-path-maturity-2.png differ diff --git a/vignettes/figures/fims-path-maturity-3.png b/vignettes/figures/fims-path-maturity-3.png index aef93bd14..77fcb1377 100644 Binary files a/vignettes/figures/fims-path-maturity-3.png and b/vignettes/figures/fims-path-maturity-3.png differ diff --git a/vignettes/figures/fims-path-maturity-4.png b/vignettes/figures/fims-path-maturity-4.png index 62e27d6fe..f268795a8 100644 Binary files a/vignettes/figures/fims-path-maturity-4.png and b/vignettes/figures/fims-path-maturity-4.png differ diff --git a/vignettes/figures/fims-path-maturity-5.png b/vignettes/figures/fims-path-maturity-5.png index 58160b323..cf0f05ce7 100644 Binary files a/vignettes/figures/fims-path-maturity-5.png and b/vignettes/figures/fims-path-maturity-5.png differ diff --git a/vignettes/figures/fims-path-maturity-6.png b/vignettes/figures/fims-path-maturity-6.png index e6c57aef9..693f7057c 100644 Binary files a/vignettes/figures/fims-path-maturity-6.png and b/vignettes/figures/fims-path-maturity-6.png differ diff --git a/vignettes/figures/fims-path-maturity-7.png b/vignettes/figures/fims-path-maturity-7.png index e8afde06e..631e30997 100644 Binary files a/vignettes/figures/fims-path-maturity-7.png and b/vignettes/figures/fims-path-maturity-7.png differ diff --git a/vignettes/figures/fims-path-maturity-8.png b/vignettes/figures/fims-path-maturity-8.png index 52bb66a1f..63e80087c 100644 Binary files a/vignettes/figures/fims-path-maturity-8.png and b/vignettes/figures/fims-path-maturity-8.png differ diff --git a/vignettes/figures/fims-path-maturity.pptx b/vignettes/figures/fims-path-maturity.pptx index 87ee6b46e..bcc9afe4e 100644 Binary files a/vignettes/figures/fims-path-maturity.pptx and b/vignettes/figures/fims-path-maturity.pptx differ diff --git a/vignettes/figures/selectivity_logging_entry.png b/vignettes/figures/selectivity_logging_entry.png new file mode 100644 index 000000000..dc91d1877 Binary files /dev/null and b/vignettes/figures/selectivity_logging_entry.png differ diff --git a/vignettes/fims-demo.Rmd b/vignettes/fims-demo.Rmd index b204c53f0..797459790 100644 --- a/vignettes/fims-demo.Rmd +++ b/vignettes/fims-demo.Rmd @@ -10,367 +10,330 @@ vignette: > ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) -# library(dplyr) ``` -## Fisheries Integrated Modeling System -The NOAA Fisheries Integrated Modeling System (FIMS) is a new modeling framework for fisheries modeling. FIMS is a software system designed and architected to support next-generation fisheries stock assessment, ecosystem, and socioeconomic modeling. It's important to note that FIMS itself is not a model, but rather a framework for creating models. The framework is made up of many modules that come together to create a "the best model" that suites the needs of the end-user. What follows is a demo of creating a catch-at-age assessment model using FIMS. +## FIMS +The NOAA Fisheries Integrated Modeling System (FIMS) is a new modeling framework for fisheries modeling. The framework is designed to support next-generation fisheries stock assessment, ecosystem, and socioeconomic modeling. It is important to note that FIMS itself is not a model but rather a framework for creating models. The framework is made up of many modules that come together to create a model that best suits the needs of the end-user. The remainder of this vignette walks through what is absolutely necessary to run a FIMS catch-at-age model using the default settings. -## Creating Models in FIMS -To begin, we import the FIMS and TMB libraries. Calling `library(FIMS)` automatically loads the Rcpp functions and modules into the R environment. The function call, `clear()`, ensures C++ memory from any previous fims model run is cleared out. -```{r fims1, warning=FALSE, message=FALSE} -# automatically loads fims Rcpp module +## Memory + +Calling `library(FIMS)` loads the R package and Rcpp functions and modules into the R environment. The C++ code is compiled upon installation rather than loading so the call to `library()` should be pretty fast. Users should always run `clear()` prior to modeling to ensure that the C++ memory from any previous FIMS model run is cleared out. +```{r memory, warning=FALSE, message=FALSE} library(FIMS) -library(TMB) +library(ggplot2) # clear memory clear() ``` -## Setting up Data -Data and variable values are taken from the [Li et. al.](https://spo.nmfs.noaa.gov/content/fishery-bulletin/comparison-4-primary-age-structured-stock-assessment-models-used-united) Model Comparison project ([github site](https://github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison)). See [R/data_mile1.R](https://github.com/NOAA-FIMS/FIMS/blob/main/R/data_mile1.R) and [tests/testthat/test-fims-estimation.R](https://github.com/NOAA-FIMS/FIMS/blob/integration-test-estimation-R-clear-FIMS/tests/testthat/test-fims-estimation.R) for details on how data and variable values are read into FIMS from the Model Comparison project. +## Data -First let's set up the dimensions of the model based on the Model Comparison project: -```{r fims-dims} -nyears <- 30 # the number of years which we have data for. -nseasons <- 1 # the number of seasons in each year. FIMS currently defaults to 1 -ages <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) # age vector. -nages <- 12 # the number of age groups. -``` +Data for a FIMS model must be stored in a single data frame with a long format, e.g., `data("data1", package = "FIMS")`. The design is similar to running a linear model where you pass a single data frame to `lm()`. The long format does lead to some information being duplicated. For example, the units are listed for every row rather than stored in a single location for each data type. But, the long format facilitates using tidy functions to manipulate the data. And, a single function, i.e., `FIMSFrame()`, is all that is needed to prepare the data to be used in a FIMS model. -### Preparing Data using FIMSFrame +### `data1` - We will be reading data into the model using the FIMSFrame S4 R class set up in [R/fimsframe.R](https://github.com/NOAA-FIMS/FIMS/blob/main/R/fimsframe.R) +A sample data frame for a catch-at-age model with both ages and lengths is stored in the package as `data1`. This data set is based on data that was used in [Li et al.](https://www.doi.org/10.7755/FB.119.2-3.5) for the Model Comparison Project ([github site](https://github.com/Bai-Li-NOAA/Age_Structured_Stock_Assessment_Model_Comparison)). The length data have since been added [data-raw/data1.R](https://github.com/NOAA-FIMS/FIMS/blob/main/data-raw/data1.R) based on an age-length conversion matrix. See [R/data1.R](https://github.com/NOAA-FIMS/FIMS/blob/main/R/data1.R) or `?data1` for details about the package data. -```{r fimsframe} -# use FIMS data frame -data(package = "FIMS") -fims_frame <- FIMSFrame(data_mile1) -``` +### `FIMSFrame()` -The `fims_frame` object contains a `@data` slot that holds a long data frame with catch data for the fishery and index data for the survey: +The easiest way to prepare the data for a FIMS model is to use `FIMSFrame()`. This function performs several validation checks and returns an object of the S4 class called `FIMSFrame`. There are helper functions for working with a `FIMSFrame` object, e.g., `get_data()`, `get_n_years()`, `get_*()`. Additionally, there are helper functions for pulling data out of the S4 class in the format needed for a module, i.e., a vector, but these `m_*()` functions are largely meant to be used internally within the package and are only exported to allow for their use by power users wishing to manually set up. -```{r ageframe} -str(fims_frame) -fims_frame@data |> - dplyr::filter(type == "landings") |> - utils::head() -fims_frame@data |> - dplyr::filter(type == "index") |> - utils::head() +```{r FIMSFrame} +# Bring the package data into your environment +data("data1") +# Prepare the package data for being used in a FIMS model +data_4_model <- FIMSFrame(data1) ``` +The S4 object that we named `data_4_model` contains many slots (i.e., named components of the object that can be accessed) but perhaps the most interesting one is the long data frame stored in the "data" slot. The tibble stored in this slot can be accessed using `get_data()`. + +```{r FIMSFrame-view} +# Use show() to see what is stored in the FIMSFrame S4 class +methods::show(data_4_model) +# Or, look at the structure using str() +# Increase max.level to see more of the structure +str(data_4_model, max.level = 1) +# Use dplyr to subset the data for just the landings +get_data(data_4_model) |> + dplyr::filter(type == "landings") +``` -Using this data frame, we will start setting up the FIMS data objects. This example from the Model Comparison project sets up a single fishery fleet with age composition and catch data and a single survey with age composition data and an index. Data are read into FIMS as long vectors, regardless of their original dimension, hence the motivation behind the long data frames created with the fimsframe S4 classes. +The data contains the following fleets: -```{r data} -# fishery data -fishery_catch <- FIMS::m_landings(fims_frame) -fishery_agecomp <- FIMS::m_agecomp(fims_frame, "fleet1") +- A single fishery fleet with age- and length-composition, weight-at-age, and landings data +- A single survey with age- and length-composition and index data -# survey data -survey_index <- FIMS::m_index(fims_frame, "survey1") +## Parameters -# survey agecomp not set up in fimsframe yet -survey_agecomp <- FIMS::m_agecomp(fims_frame, "survey1") -``` +The parameters that are in the model will depend on which modules are used from the FIMS framework. This combination of modules rather than the use of a control file negates the need for complicated if{} else{} statements in the code. -## Creating Modules in FIMS -Now that we've prepared the data, let's pass it into FIMS. Each module in the FIMS-R interface is made of S4 objects. These S4 objects serve as a interface between R and the underlining C++ code that defines FIMS. Modules are instantiated using the `methods::new()` function. We can use `methods::show()` to view all the fields (i.e. variables) and methods (i.e. functions) available in a given module. +### `create_default_parameters()` -### The Fleet Module +By passing the data to `create_default_parameters()` the function can tailor the defaults based on how many fleets there are and what data types exist. For example, if you have three fleets, then `create_default_parameters()` will set up three logistic selectivity modules. -#### Fleet Data +Modules that are available in FIMS are known as reference classes in the C++ code. Each reference class acts as an interface between R and the underlining C++ code that defines FIMS. Several reference classes exist and several more will be created in the future. The beauty of having modules rather than a control file really comes out when more reference classes are created because each reference class can be accessed through R by itself to build up a model rather than needing to modify a control file for future features. -Each fleet is required to have data in order to evaluate the objective function. Currently FIMS only has a fleet module that is used to set up both fleets and surveys. FIMS contains an Index module and AgeComp module to pass data objects into the fleet module. Each of these data modules require a dimension be added to indicate the dimensions of the raw data (e.g. nyears x nages matrix). Any years with missing data should be specified with a value set to -999. Given this information, FIMS is able to correctly apply dimension folding for model output. +By just passing lists of fleet specifications and the data to `create_default_parameters()`, the default values for parameters that relate to fleet(s), recruitment, growth, and maturity modules can be created. For example, -Using the `methods::show()` function, we can see that the Index module has a vector field named *index_data* and the AgeComp module has a vector field names *age_comp_data*. + - "BevertonHoltRecruitment" for the recruitment module + - "DnormDistribution" for recruitment deviations (log_devs) + - "EWAAgrowth" for the growth module, and + - "LogisticMaturity" for maturity module. -```{r fleet-show} -show(Index) -show(AgeComp) +```{r parameters, max.height='100px', attr.output='.numberLines'} +# Define the same fleet specifications for fleet1 and survey1 +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" + ) +) + +# Create default recruitment, growth, and maturity parameters +default_parameters <- data_4_model |> + create_default_parameters( + fleets = list(fleet1 = fleet1, survey1 = survey1) + ) ``` -We'll create both index and age composition modules for the fleet using the `methods::new()` function and pass in the data defined above from the Model Comparison project. -```{r fleet-set-data} -# fleet index data -fishing_fleet_index <- methods::new(Index, nyears) -# fleet age composition data -fishing_fleet_age_comp <- methods::new(AgeComp, nyears, nages) -fishing_fleet_index$index_data <- fishery_catch # unit: mt -# Effective sampling size is 200 -fishing_fleet_age_comp$age_comp_data <- fishery_agecomp * 200 # unit: number at age; proportion at age also works +The argument names and their corresponding default values of the create_default_parameters() function can be displayed using `args()`. +```{r parameters-args} +args(create_default_parameters) ``` -#### Fleet Selectivity -Now that we've passed in data for the fishing fleet, we need to set up its selectivity module. We will set this to be selectivity function using the LogisticSelectivity module. The`methods::show()` function indicates this module has two parameter fields: *inflection_point* and *slope*, and an `evaluate()` and `get_id()` function. - -Each variable of [Parameter class](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp) has three additional fields: *value*, *is_random_effect*, and *estimated*. Currently, FIMS is not set up to run random effects. The default value for this field and the *estimate* field is currently set to `FALSE`. We can use the *value* field to input variables defined in the Model Comparison project. - -```{r fleet_selectivity} -methods::show(LogisticSelectivity) -fishing_fleet_selectivity <- methods::new(LogisticSelectivity) -fishing_fleet_selectivity$inflection_point$value <- 2.0 -fishing_fleet_selectivity$inflection_point$is_random_effect <- FALSE -fishing_fleet_selectivity$inflection_point$estimated <- TRUE -fishing_fleet_selectivity$slope$value <- 1.0 -fishing_fleet_selectivity$slope$is_random_effect <- FALSE -fishing_fleet_selectivity$slope$estimated <- TRUE +### `update_parameters()` + +In the future, the developers of FIMS may update the default parameters to experiment with different values. Regardless, you can still use `create_default_parameters()` as a starting point because it will provide information on the appropriate dimensions and necessary elements that the final list must contain. And, although it is a good idea to modify the returned defaults with `update_parameters()`, you can update the list manually. + +In the code below, `update_parameters()` is used to adjust the fishing mortality, selectivity, maturity, and population parameters from their default values. If the parameters are estimated, these updates will change their starting values, and if they are fixed, these updates will change their value used in the model. + +```{r parameters-update} +# Each call to update_parameters() returns the full list so the pipe can be +# used to daisy chain all of these updates together to a new object called +# parameters that will be used to fit the model +parameters <- default_parameters |> + update_parameters( + modified_parameters = list( + fleet1 = list( + Fleet.log_Fmort.value = log(c( + 0.009459165, 0.027288858, 0.045063639, + 0.061017825, 0.048600752, 0.087420554, + 0.088447204, 0.186607929, 0.109008958, + 0.132704335, 0.150615473, 0.161242955, + 0.116640187, 0.169346119, 0.180191913, + 0.161240483, 0.314573212, 0.257247574, + 0.254887252, 0.251462108, 0.349101406, + 0.254107720, 0.418478117, 0.345721184, + 0.343685540, 0.314171227, 0.308026829, + 0.431745298, 0.328030899, 0.499675368 + )) + ) + ) + ) |> + update_parameters( + modified_parameters = list( + survey1 = list( + LogisticSelectivity.inflection_point.value = 1.5, + LogisticSelectivity.slope.value = 2, + Fleet.log_q.value = log(3.315143e-07) + ) + ) + ) |> + update_parameters( + modified_parameters = list( + recruitment = list( + BevertonHoltRecruitment.log_rzero.value = log(1e+06), + BevertonHoltRecruitment.log_devs.value = c( + 0.43787763, -0.13299042, -0.43251973, 0.64861200, 0.50640852, + -0.06958319, 0.30246260, -0.08257384, 0.20740372, 0.15289604, + -0.21709207, -0.13320626, 0.11225374, -0.10650836, 0.26877132, + 0.24094126, -0.54480751, -0.23680557, -0.58483386, 0.30122785, + 0.21930545, -0.22281699, -0.51358369, 0.15740234, -0.53988240, + -0.19556523, 0.20094360, 0.37248740, -0.07163145 + ), + BevertonHoltRecruitment.log_devs.estimated = FALSE + ) + ) + ) |> + update_parameters( + modified_parameters = list( + maturity = list( + LogisticMaturity.inflection_point.value = 2.25, + LogisticMaturity.inflection_point.estimated = FALSE, + LogisticMaturity.slope.value = 3, + LogisticMaturity.slope.estimated = FALSE + ) + ) + ) |> + update_parameters( + modified_parameters = list( + population = list( + Population.log_init_naa.value = c( + 13.80944, 13.60690, 13.40217, 13.19525, 12.98692, 12.77791, + 12.56862, 12.35922, 12.14979, 11.94034, 11.73088, 13.18755 + ) + ) + ) + ) ``` -#### Creating the Fleet Object -Now that we've created everything that a fleet needs, lets create the actual fleet object. First let's run `methods::show(Fleet)` to see all the fields and methods available from R. +## Fit -```{r show-Fleet} -show(Fleet) -``` -We can see that there are five boolean flags: estimate_F, estimate_q, and is_survey, random_F, and random_q. There are two vectors, log_Fmort and log_obs_error, and a double, log_q. There are two integer fields for the number of ages and years. Additionally, there are five Methods: SetAgeCompLikelihood, SetIndexLikelihood, SetObservedAgeCompData, SetObservedIndexData, and setSelectivity. The last three of these will be used to link up the AgeComp, Index, and Selectivity modules defined above with the fleet module defined below. - - -```{r fleet} -# Create fleet module -fishing_fleet <- methods::new(Fleet) -# Set nyears and nages -fishing_fleet$nages <- nages -fishing_fleet$nyears <- nyears -# Set values for log_Fmort -fishing_fleet$log_Fmort <- log(c( - 0.009459165, 0.02728886, 0.04506364, - 0.06101782, 0.04860075, 0.08742055, - 0.0884472, 0.1866079, 0.109009, 0.1327043, - 0.1506155, 0.161243, 0.1166402, 0.1693461, - 0.1801919, 0.1612405, 0.3145732, 0.2572476, - 0.2548873, 0.2514621, 0.3491014, 0.2541077, - 0.4184781, 0.3457212, 0.3436855, 0.3141712, - 0.3080268, 0.4317453, 0.3280309, 0.4996754 -)) -# Turn on estimation for F -fishing_fleet$estimate_F <- TRUE -fishing_fleet$random_F <- FALSE -# Set value for log_q -fishing_fleet$log_q <- log(1.0) -fishing_fleet$estimate_q <- FALSE -fishing_fleet$random_q <- FALSE -fishing_fleet$log_obs_error <- rep(log(sqrt(log(0.01^2 + 1))), nyears) -fishing_fleet$estimate_obs_error <- FALSE -# Next two lines not currently used by FIMS -fishing_fleet$SetAgeCompLikelihood(1) -fishing_fleet$SetIndexLikelihood(1) -# Set Index, AgeComp, and Selectivity using the IDs from the modules defined above -fishing_fleet$SetObservedIndexData(fishing_fleet_index$get_id()) -fishing_fleet$SetObservedAgeCompData(fishing_fleet_age_comp$get_id()) -fishing_fleet$SetSelectivity(fishing_fleet_selectivity$get_id()) -``` +With data and parameters in place, we can now initialize modules using `initialize_fims()` and fit the model using `fit_fims()`. -### The Survey Module -We will now repeat the steps from Fleet to set up the Survey. A survey object is essentially the same as a fleet object with a catchability (q) variable. +### `initialize_fims()` -#### Survey Data +The list returned by `create_default_parameters()` has two elements, parameters and modules. But, these are just lists of lists containing specifications. Nothing has been created in memory as of yet. To actually initialize the modules specified in `parameters[["modules"]]`, `initialize_fims()` needs to be called. This function takes all of the specifications and matches them with the appropriate data to initialize a module and create the pointers to the memory. -```{r survey-set-data} -# fleet index data -survey_fleet_index <- methods::new(Index, nyears) -# survey age composition data -survey_fleet_age_comp <- methods::new(AgeComp, nyears, nages) -survey_fleet_index$index_data <- survey_index # unit: mt; it's possible to use other units as long as the index is assumed to be proportional to biomass -# Effective sampling size is 200 -survey_fleet_age_comp$age_comp_data <- survey_agecomp * 200 # unit: number at age; proportion at age also works -``` +### `fit_fims()` -#### Survey Selectivity +The list returned from `initialize_fims()` can be passed to the parameter of `fit_fims()` called `input` to run a FIMS model. If `optimize = FALSE`, the model will not actually be optimized but instead just checked to ensure it is a viable model. When `optimize = TRUE`, the model will be fit using `stats::nlminb()` and an object of the class `FIMSFit` will be returned. -```{r survey-selectivity} -survey_fleet_selectivity <- new(LogisticSelectivity) -survey_fleet_selectivity$inflection_point$value <- 1.5 -survey_fleet_selectivity$inflection_point$is_random_effect <- FALSE -survey_fleet_selectivity$inflection_point$estimated <- TRUE -survey_fleet_selectivity$slope$value <- 2.0 -survey_fleet_selectivity$slope$is_random_effect <- FALSE -survey_fleet_selectivity$slope$estimated <- TRUE -``` +### Example -#### Creating the Survey Object - -```{r survey} -survey_fleet <- methods::new(Fleet) -survey_fleet$is_survey <- TRUE -survey_fleet$nages <- nages -survey_fleet$nyears <- nyears -survey_fleet$estimate_F <- FALSE -survey_fleet$random_F <- FALSE -survey_fleet$log_q <- log(3.315143e-07) -survey_fleet$estimate_q <- TRUE -survey_fleet$random_q <- FALSE -# sd = sqrt(log(cv^2 + 1)), sd is log transformed -survey_fleet$log_obs_error <- rep(log(sqrt(log(0.2^2 + 1))), nyears) -survey_fleet$estimate_obs_error <- FALSE -survey_fleet$SetAgeCompLikelihood(1) -survey_fleet$SetIndexLikelihood(1) -survey_fleet$SetSelectivity(survey_fleet_selectivity$get_id()) -survey_fleet$SetObservedIndexData(survey_fleet_index$get_id()) -survey_fleet$SetObservedAgeCompData(survey_fleet_age_comp$get_id()) -``` - - -### Creating a Population -The final step is to set up the population module. Before doing so, we first need to set up each component of the population (e.g. recruitment, growth, etc.). - -#### Recruitment -We'll use a Beverton Holt recruitment module. We first instantiate a module using the `methods::new()` function. We can use `methods::show()` to view all the fields (i.e. variables) and methods (i.e. functions) available in `BevertonHoltRecruitment` module. - -```{r recruitment} -# Recruitment -recruitment <- methods::new(BevertonHoltRecruitment) -methods::show(BevertonHoltRecruitment) -``` -There are three parameters we need to set-up: *log_sigma_recruit*, *log_rzero*, and *logit_steep*. - -```{r set-up-recruitment} -recruitment$log_sigma_recruit$value <- log(0.4) -recruitment$log_rzero$value <- log(1e+06) # unit: log(number) -recruitment$log_rzero$is_random_effect <- FALSE -recruitment$log_rzero$estimated <- TRUE -recruitment$logit_steep$value <- -log(1.0 - 0.75) + log(0.75 - 0.2) -recruitment$logit_steep$is_random_effect <- FALSE -recruitment$logit_steep$estimated <- FALSE +```{r fit, max.height='100px', attr.output='.numberLines', eval=TRUE} +# Run the model without optimization to help ensure a viable model +test_fit <- parameters |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = FALSE) + +# Run the model with optimization +fit <- parameters |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = TRUE) + +# Get information about the model and print a few characters to the screen +recruitment_log <- get_log_module("information") +substr(recruitment_log, 1, 100) + +# Clear memory post-run +clear() ``` -We also need to set up log recruitment deviations. FIMS recruitment modules have a boolean, *estimate_log_devs* to specify whether or not log deviations are estimated; and a vector, *log_devs* to set the log deviation values. - -```{r rec-devs} -recruitment$estimate_log_devs <- FALSE -recruitment$log_devs <- c( - 0.08904850, 0.43787763, -0.13299042, -0.43251973, - 0.64861200, 0.50640852, -0.06958319, 0.30246260, - -0.08257384, 0.20740372, 0.15289604, -0.21709207, - -0.13320626, 0.11225374, -0.10650836, 0.26877132, - 0.24094126, -0.54480751, -0.23680557, -0.58483386, - 0.30122785, 0.21930545, -0.22281699, -0.51358369, - 0.15740234, -0.53988240, -0.19556523, 0.20094360, - 0.37248740, -0.07163145 +The results can be plotted with either base R or using {ggplot2}. + +```{r fit-plots} +index_results <- data.frame( + observed = m_index(data_4_model, "survey1"), + expected = get_report(fit)[["exp_index"]][[2]], + years = get_start_year(data_4_model):get_end_year(data_4_model) ) -``` -#### Growth -Now, we'll define the growth module for our population using an empirical weight at age model. -```{r growth} -# Growth -ewaa_growth <- methods::new(EWAAgrowth) -ewaa_growth$ages <- ages -ewaa_growth$weights <- c( - 0.0005306555, 0.0011963283, 0.0020582654, - 0.0030349873, 0.0040552124, 0.0050646975, - 0.0060262262, 0.0069169206, 0.0077248909, - 0.0084461128, 0.0090818532, 0.0096366950 -) # unit: mt -``` -#### Maturity -Each population will also need a maturity model. Here we define a logistic maturity model. -```{r maturity} -# Maturity -maturity <- new(LogisticMaturity) -maturity$inflection_point$value <- 2.25 -maturity$inflection_point$is_random_effect <- FALSE -maturity$inflection_point$estimated <- FALSE -maturity$slope$value <- 3 -maturity$slope$is_random_effect <- FALSE -maturity$slope$estimated <- FALSE -``` +print(index_results) -Now that our life history sub-models are defined, lets define the actual population. - -```{r population} -# Population -population <- new(Population) -population$log_M <- rep(log(0.2), nyears * nages) -population$estimate_M <- FALSE -population$log_init_naa <- log(c( - 993947.5, 811707.8, 661434.4, - 537804.8, 436664.0, 354303.4, - 287397.0, 233100.2, 189054.0, - 153328.4, 124353.2, 533681.3 -)) # unit: in number -population$estimate_init_naa <- TRUE -population$nages <- nages -population$ages <- ages -population$nfleets <- 2 # 1 fleet and 1 survey -population$nseasons <- nseasons -population$nyears <- nyears -``` +ggplot2::ggplot(index_results, ggplot2::aes(x = years, y = observed)) + + ggplot2::geom_point() + + ggplot2::xlab("Year") + + ggplot2::ylab("Index (mt)") + + ggplot2::geom_line(ggplot2::aes(x = years, y = expected), color = "blue") + + ggplot2::theme_bw() -Now we need to link up the recruitment, growth, and maturity modules we set above with this new population module. We do this by calling `get_id()` from each respective module and passing that unique ID into each respective `Set` function from population. +catch_results <- data.frame( + observed = m_landings(data_4_model, fleet = "fleet1"), + expected = get_report(fit)[["exp_index"]][[1]], + years = get_start_year(data_4_model):get_end_year(data_4_model) +) +print(catch_results) -```{r set-pop-modules} -population$SetMaturity(maturity$get_id()) -population$SetGrowth(ewaa_growth$get_id()) -population$SetRecruitment(recruitment$get_id()) +ggplot2::ggplot(catch_results, ggplot2::aes(x = years, y = observed)) + + ggplot2::geom_point() + + ggplot2::xlab("Year") + + ggplot2::ylab("Index (mt)") + + ggplot2::geom_line(ggplot2::aes(x = years, y = expected), color = "blue") + + ggplot2::theme_bw() ``` +### Sensitivities -## Putting It All Together +Multiple fits, i.e., sensitivity runs, can be set up by modifying the parameter list using `update_parameters()` or changing the data that is used to fit the model. -### Creating the FIMS Model and Making the TMB Function +#### Initial values -```{r model} -sucess <- CreateTMBModel() -parameters <- list(p = get_fixed()) -obj <- MakeADFun(data = list(), parameters, DLL = "FIMS", silent = TRUE) -``` -## Fitting the Model -```{r fit_model} -opt <- nlminb(obj$par, obj$fn, obj$gr, - control = list(eval.max = 800, iter.max = 800) -) # , method = "BFGS", -# control = list(maxit=1000000, reltol = 1e-15)) - -print(opt) -``` +For example, one could change the initial value used for the slope of the logistic curve for the survey to see if the terminal estimate changes due to changes to the initial value. + +```{r initial-values} +parameters_high_slope <- parameters |> + update_parameters( + modified_parameters = list( + survey1 = list( + LogisticSelectivity.slope.value = 2.5 + ) + ) + ) -### TMB Reporting -```{r tmb_report} -sdr <- TMB::sdreport(obj) -sdr_fixed <- summary(sdr, "fixed") -report <- obj$report(obj$env$last.par.best) +parameters_low_slope <- parameters |> + update_parameters( + modified_parameters = list( + survey1 = list( + LogisticSelectivity.slope.value = 1 + ) + ) + ) -print(sdr_fixed) +high_slope_fit <- parameters_high_slope |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = TRUE) -# report out nll components -report$rec_nll # recruitment -report$index_nll # fishery catch and survey index -report$age_comp_nll # fishery and survey age composition +clear() + +low_slope_fit <- parameters_low_slope |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = TRUE) + +clear() ``` +#### Age only -## Plotting Results -```{r plots} -library(ggplot2) -index_results <- data.frame( - observed = survey_fleet_index$index_data, - expected = report$exp_index[[2]] +The same model can be fit to just the age data, removing the length data. + +```{r age} +# Define fleet and survey with age-specific data distribution +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution" + ) ) -print(index_results) -ggplot(index_results, aes(x = 1:nyears, y = observed)) + - geom_point() + - xlab("Year") + - ylab("Index (mt)") + - geom_line(aes(x = 1:nyears, y = expected), color = "blue") + - theme_bw() +# Create default parameters, update with modified values, initialize FIMS, +# and fit the model +age_only_fit <- data_4_model |> + create_default_parameters( + fleets = list(fleet1 = fleet1, survey1 = survey1) + ) |> + # update_parameters(modified_parameters = parameters$parameters) |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = TRUE) -catch_results <- data.frame( - observed = fishing_fleet_index$index_data, - expected = report$exp_index[[1]] +clear() +``` + +#### Length + +The same model can be fit to just the length data, removing the age data. + +```{r length} +# Define fleet and survey with length-specific data distribution +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + LengthComp = "DmultinomDistribution" + ) ) -print(catch_results) -ggplot(catch_results, aes(x = 1:nyears, y = observed)) + - geom_point() + - xlab("Year") + - ylab("Index (mt)") + - geom_line(aes(x = 1:nyears, y = expected), color = "blue") + - theme_bw() -``` +# Create default parameters, update with modified values, initialize FIMS, +# and fit the model +length_only_fit <- data_4_model |> + create_default_parameters( + fleets = list(fleet1 = fleet1, survey1 = survey1) + ) |> + update_parameters(modified_parameters = parameters$parameters) |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = TRUE) -## Clear C++ objects from memory -```{r clear} clear() ``` diff --git a/vignettes/fims-documentation.Rmd b/vignettes/fims-documentation.Rmd index 01015a030..cf23c4d7f 100644 --- a/vignettes/fims-documentation.Rmd +++ b/vignettes/fims-documentation.Rmd @@ -159,7 +159,8 @@ doc_list <- list( ``` ```{r list-to-markdown, echo=FALSE, warning=FALSE, message=FALSE} -library(tidyverse) +library(dplyr) +library(tibble) list2markdown <- function(list) { enframe(list) |> diff --git a/vignettes/fims-logging.Rmd b/vignettes/fims-logging.Rmd new file mode 100644 index 000000000..cec14e9bb --- /dev/null +++ b/vignettes/fims-logging.Rmd @@ -0,0 +1,116 @@ +--- +title: "Introducing the FIMS Logging System" +output: github_document +vignette: > + %\VignetteIndexEntry{Introducing the FIMS Logging System} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r fims1, warning=FALSE, message=FALSE, include = FALSE} +# automatically loads fims Rcpp module +library(FIMS) + +# clear memory +clear() +``` + +```{r set-up-model, include=FALSE} +# use FIMS data frame +data_4_model <- FIMSFrame(data1) +fleet1 <- survey1 <- list( + selectivity = list(form = "LogisticSelectivity"), + data_distribution = c( + Index = "DlnormDistribution", + AgeComp = "DmultinomDistribution" + ) +) + +# Create default parameters +default_parameters <- data_4_model |> + create_default_parameters(fleets = list(fleet1 = fleet1, survey1 = survey1)) +``` + +## Importance of Logging + +Logging in FIMS is important because it allows developers to understand what is happening within a model. It is especially useful when problems arise. The FIMS logging system has been designed to handle common issues, such as undefined modules, dimension issues, and software errors that may occur when a model is not properly defined. This logging system is accessible from both R and C++ and messages are provided using a JSON format. + +## How FIMS Logging works + +At run time, logging messages are stored in a C++ structure called LogEntry in +inst/include/common/def.hpp. This structure contains useful information, such as information regarding when the LogEntry was created and what portion of the code initiated its creation. For details regarding the contents of a LogEntry see the doxygen documentation. All of the LogEntry(s) are stored in a log file that can be accessed from within your R environment or written to the disk. Additionally, this file can automatically be written to the disk when R fails to successfully communicate with C++. + +## Backend C++ Specification + +The logging system (specified in inst/include/common/def.hpp) provides three useful macro functions for creating log entries, `FIMS_INFO_LOG`, `FIMS_WARNING_LOG`, and `FIMS_ERROR_LOG`. These macros take a single string value as an argument, the rest is handled internally. Therefore, the developer only needs to worry about specifying the message and the macros take care of capturing all the other elements of the log entry. For example, `FIMS_INFO_LOG` is used quite a bit in information.hpp to let the user know that items were initialized appropriately. Developers can specify the information contained within the string passed to the macro to be generic or specific to values stored inside the C++ code. See below for an example of a generic message that is completely specified by the user and a more specific message that uses information stored within C++ for part of the message. Also, note that the C++ function `fims::to_string` converts a numeric value to a string, making it additive to the message. + +```{Rcpp, eval = FALSE} +FIMS_INFO_LOG("Starting to initialize the fleet structures") +FIMS_INFO_LOG("Initializing fleet " + fims::to_string(f->id)) +``` + +Below is a real-world example of a log entry that was created while running a FIMS model due to `FIMS_INFO_LOG` within [selectivity in information.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/information.hpp#L371). The log entry specifies the line of the file with the macro that led to the log entry. The screenshot below shows what the user would see if this log entry were invoked. + +![](figures/selectivity_logging_entry.png) + + +Additionally, if FIMS has been compiled with the `-DFIMS_DEBUG` pre-processing macro, output from the `FIMS_DEBUG_LOG` macro will also be available in the log file, allowing developers a more interactive developing experience. The output from this macro is turned off in the main branch, and thus, the macro is not available to the typical user to stop debugging statements from polluting the log file. + +## Using the Logging System in R + +The FIMS Logging System is also available from R, with a caveat! Logging from R gives less information than logging from C++. When a log entry originates from R, file, routine, and line information are absent. Further implementations may rectify this issue. Below are examples of adding log entries from R. + +```{r rlogging_info, eval=FALSE} +log_info("info entry from R script") +log_warning("warning entry from R script") +``` +```{r rlogging_error, eval=TRUE} +error <- log_error("error entry from R script") +get_log_errors() +``` + +In the above example of an error level log entry, notice the R stack trace in the routine field. Sometimes this may contain useful information, but most of the time the stack trace is to large to capture the root cause of the error. For that reason, it's advised to make the error message as detailed as possible when calling `log_error(x)` from R. Note that the formatting is better when written to a file rather than printed to the screen as is done here. + +### **FIMS Logging Functions in R** + +There are several exported logging functions in the FIMS packages. To find out more about each of the following functions, use `methods::show()` to view the documentation. + +```{r} +ls("package:FIMS") |> + grep(pattern = "_log|log_", value = TRUE) |> + cli::cli_bullets() + +# Get documentation for log_error +methods::show(log_error) +``` + +## Example of FIMS logging from R + +Assuming a model has already been defined in the object `default_parameters`, below is an example of using the logging system with FIMS in R. + +```{r example_code, eval = TRUE} +fit <- default_parameters |> + initialize_fims(data = data_4_model) |> + fit_fims(optimize = TRUE) + +# get the log as a string in JSON format and parse into a list +log_str <- as.character(get_log()) +write(log_str, "log.json") +log_json <- jsonlite::fromJSON(log_str) + +# get log warnings only +log_warnings_str <- get_log_warnings() + +# get log errors only +log_errors_str <- get_log_errors() + +# get log entries from the information module +information_log <- get_log_module("information") +``` + +Another useful option is `set_throw_on_error()`. If this option is set to TRUE, FIMS will abort immediately when an error occurs and if `write_log(TRUE)` was previously called, the log file will be written before FIMS terminates the session. Below is an example of how to throw on error. + +```{r throw, eval = FALSE} +set_log_throw_on_error(TRUE) +log_error("throwing now!") +``` diff --git a/vignettes/fims-path-maturity.Rmd b/vignettes/fims-path-maturity.Rmd index 744a65137..c6c8fbeab 100644 --- a/vignettes/fims-path-maturity.Rmd +++ b/vignettes/fims-path-maturity.Rmd @@ -16,7 +16,6 @@ knitr::opts_chunk$set( ```{css, echo=FALSE} - .rchunk { border: solid #2e75b6; } @@ -38,147 +37,172 @@ code span.co{ } -This vignette describes the hierarchical structure of FIMS by describing the linkages, or *path* through the FIMS model using maturity as an example. The vignette is tailored to FIMS developers or others interested in understanding the FIMS core architecture. The vignette walks through how user provided input from R is carried into the core FIMS calculations. +This vignette describes the hierarchical structure of FIMS by describing the linkages, or *path*, from R to C++ using maturity as an example. The vignette is tailored to developers or others interested in understanding the core of FIMS. With each example of R code that follows there are explanations of how that code is linked to the C++ code. -The vignette will build up components to the final path: +The following diagram represents the complete path from R to C++ for the maturity module. The following sections break this diagram into simplified parts using a common color coding, where R code is in blue, code for the Rcpp interface that links R objects to C++ objects is in orange, the C++ code that acts as the core of FIMS is in green, and the C++ code that makes up `Information` is in grey. ```{r image-path-maturity-8a, echo = FALSE, message=FALSE, out.width = '100%'} knitr::include_graphics("figures/fims-path-maturity-8.png") ``` -Code chunks in this vignette will be color coded similar to this diagram: R code in blue, Rcpp interface code in orange, fims core code in green, and information in grey. +## Modules in R + +FIMS is comprised of several modules that can be linked together to create a model. The maturity module is just one of them but will serve as the example in this vignette. Modules are written in C++ and linked to R using Rcpp. To retrieve a module from the C++ code it must be set up in R and then populated with parameters. + +After loading FIMS and the default data set that comes with FIMS, a maturity module can be created using a list. It is easiest to populate this list using wrapper functions that are written in R. The list that specifies how the module will be created can be updated from the defaults using [update_parameters()]. It is often easier to create the defaults and update them rather than creating the list by yourself because the wrapper functions will ensure the proper structure is used. That way you do not have to memorize what the structure is supposed to look like. Last, the list is used to create the module, using another wrapper function. + +```{r, class.source = "rchunk", eval = TRUE} +# Load the FIMS package +library(FIMS) + +# Load a built-in data set from the FIMS package +data("data1") + +# Convert the data into a FIMSFrame object, which is an S4 class. +# See ?FIMSFrame for more information. +fims_frame <- FIMSFrame(data1) + +# Create default maturity parameters using internal function +default_parameters <- list( + parameters = FIMS:::create_default_maturity(form = "LogisticMaturity"), + modules = list(maturity = list(form = "LogisticMaturity")) +) +show(default_parameters) + +# The default maturity parameters can be updated +parameters <- default_parameters |> + update_parameters( + modified_parameters = list( + maturity = list( + LogisticMaturity.inflection_point.value = 2.25, + LogisticMaturity.inflection_point.estimated = FALSE, + LogisticMaturity.slope.value = 3, + LogisticMaturity.slope.estimated = FALSE + ) + ) + ) +show(parameters) -## Setting up a module in R +# Initialize maturity module based on the list of parameters +maturity <- FIMS:::initialize_maturity( + parameters = parameters, + data = fims_frame +) +``` -We'll start from R. The first step is to retrieve the FIMS module, create a new maturity module inside FIMS, and populate the maturity module with parameter values. +For power users, the methods package can be used to call Rcpp and create the module without using lists of parameters or any wrapper functions. The following code also creates the same maturity module. -```{r, class.source = "rchunk", eval = FALSE} +```{r maturity-power-user, class.source = "rchunk", eval = FALSE} # load FIMS library(FIMS) # Create a new maturity model -maturity <- new(LogisticMaturity) +maturity <- methods::new(LogisticMaturity) # Populate the maturity module with parameter values. -maturity$inflection_point$value <- 10 -maturity$inflection_point$is_random_effect <- FALSE -maturity$inflection_point$estimated <- FALSE -maturity$slope$value <- 0.2 -maturity$slope$is_random_effect <- FALSE -maturity$slope$estimated <- FALSE +maturity$inflection_point[1]$value <- 10 +maturity$inflection_point[1]$is_random_effect <- FALSE +maturity$inflection_point[1]$estimated <- FALSE +maturity$slope[1]$value <- 0.2 +maturity$slope[1]$is_random_effect <- FALSE +maturity$slope[1]$estimated <- FALSE +``` + +To run a FIMS model, more modules than just a maturity module need to be linked to a population module. But, this example only includes a maturity module so the code below is just pseudo code showing how to link a maturity module to a population module. The code below assumes that growth and recruitment modules, i.e., modules 2 and 3, have already been set up. + +```{r population, class.source = "rchunk", eval = FALSE} +# Initialize the population module and link the maturity module +# The IDs of the growth and recruitment modules are pseudo code and don't exist +population <- FIMS:::initialize_population( + parameters = parameters, + data = fims_frame, + linked_ids = setNames( + c(maturity$get_id(), 2, 3), + c("maturity", "growth", "recruitment") + ) +) ``` -After that, we need to create and set up a population and link the maturity module to the population: +For power users, the methods package can be used to call Rcpp and create the population module without using lists of parameters or any wrapper functions. + ```{r, class.source = "rchunk", eval = FALSE} -population <- new(Population) -# set up population specific parameters (other modules) -# ... -# set maturity for the population - will throw error until PR #363 is merged into main +population <- methods::new(Population) population$SetMaturity(maturity$get_id()) +population$SetGrowth(2) +population$SetRecruitment(3) ``` -Because FIMS sets up objects stored in memory, simply running `rm(Fims)`, won't free this memory back up. There is a function that can be run to clear out memory: -```{r, class.source = "rchunk", eval = FALSE} +Because FIMS sets up objects that are stored in memory simply running `rm(population)` will not free this memory back up. Instead, users need to use `clear()`, which is a function written in the Rcpp interface but callable from R. Restarting or closing your R session will also work to free up the memory. +```{r, class.source = "rchunk", eval = TRUE} # Clear C++ memory clear() # Clear R memory -rm(Fims) -rm(maturity) -rm(population) +rm(list = ls()) ``` -Also restarting or closing out your R session will free up memory. -## The Rcpp Interface +## Rcpp Interface -The fields specific to the maturity module that are accessible from R are defined in the -[rcpp_interface.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_interface.hpp) file in the directory [inst/include/interface/rcpp](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp): +For each module, the Rcpp code in [rcpp_interface.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_interface.hpp) defines what fields the R user can see and set. Additional code for methods, e.g., `get_id`, constructors, and destructors are defined for each module in .hpp files found in the [inst/include/interface/rcpp](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp) directory. Only the fields and methods that are listed in the module interface, see below, are exposed to the R user. Additionally, this directory stores the code for Rcpp functions like `clear()`. ```{Rcpp, class.source = "rcppchunk", eval = FALSE} Rcpp::class_("LogisticMaturity") - .constructor() - .field("inflection_point", &LogisticMaturityInterface::inflection_point) - .field("slope", &LogisticMaturityInterface::slope) - .method("get_id", &LogisticMaturityInterface::get_id) - .method("evaluate", &LogisticMaturityInterface::evaluate); + .constructor() + .field("inflection_point", &LogisticMaturityInterface::inflection_point) + .field("slope", &LogisticMaturityInterface::slope) + .method("get_id", &LogisticMaturityInterface::get_id) + .method("evaluate", &LogisticMaturityInterface::evaluate); ``` -The code above shows that there are two maturity module-specific fields (i.e., parameters), `inflection_point` and `slope`, and two maturity module-specific methods (i.e., functions), `get_id` and `evaluate`. Defined methods are functions that can be called from R. You can access the fields and methods from R using the `show(Fims)` function. +The code above shows that there are two fields specific to the maturity module (i.e., parameters), `inflection_point` and `slope`, and methods (i.e., functions), `get_id` and `evaluate`. `get_id` method returns a unique ID for a created module. Where, you can have multiple instances of a maturity module defined in memory but only one can be used per model. Methods are functions that can be called from R. You can view all the fields and methods that are exposed to the R user for any Rcpp class by passing the quoted name inside the round brackets of any call to `Rcpp::class_<*>("")` as an unquoted string to `methods::show()`, e.g., `methods::show(LogisticMaturity)`. -The maturity module's `get_id` method returns a unique ID for this specific module. - -When creating a new module in R, users can access the module using the name in quotes from the `Rcpp::class`, `LogisticMaturity` - -```{r, class.source = "rchunk", eval = FALSE} -maturity <- new(LogisticMaturity) -``` - -This module references the maturity rcpp class, `LogisticMaturityInterface` defined in [rcpp_maturity.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp) in the directory [inst/include/interface/rcpp/rcpp_objects](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp/rcpp_objects). - -The rcpp_maturity.hpp file consists of a `MaturityInterfaceBase` class and a `LogisticMaturityInterface` class, with the former being the **parent class** and the latter being the **child class**: +LogisticMaturity references the maturity rcpp class, `LogisticMaturityInterface` defined in [rcpp_maturity.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp) in the directory [inst/include/interface/rcpp/rcpp_objects](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp/rcpp_objects). This file consists of a `MaturityInterfaceBase` class and a `LogisticMaturityInterface` class, with the former being the **parent class** and the latter being the **child class**. Sometimes there are multiple child classes under a parent class but as of now, there is only one child class, i.e., option, for maturity. It is the child classes which are referenced from R, the parent classes are just used in Rcpp to set the structure. ```{Rcpp, class.source = "rcppchunk", eval = FALSE} class MaturityInterfaceBase : public FIMSRcppInterfaceBase { public: - static uint32_t id_g; /**< static id of the recruitment interface base*/ - uint32_t id; /**< id of the recruitment interface base */ + static uint32_t id_g; /**< static id of the maturity interface base */ + uint32_t id; /**< id of the maturity interface base */ ... } class LogisticMaturityInterface : public MaturityInterfaceBase { public: - Parameter inflection_point; /**< the index value at which the response reaches .5 */ - Parameter slope; /**< the width of the curve at the inflection_point */ + /** + * @brief The value of the dependent variable at which the response reaches + * 0.5. + */ + Parameter inflection_point; + /** + * @brief The width of the curve at the inflection_point. + */ + Parameter slope; ... } ``` -We typically will reference the child class from R to specify the formulation of maturity we wish to use in a specific model run of FIMS. In this particular example, we are using the logistic form of maturity. - ```{r image-path-maturity-1, echo = FALSE, message=FALSE, out.width = '85%'} knitr::include_graphics("figures/fims-path-maturity-1.png") ``` -All Rcpp interface classes from FIMS define parameters (e.g., `inflection_point`, `slope`) using the `Parameter` class defined in [rcpp_interface_base.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp) in the directory [inst/include/interface/rcpp/rcpp_objects](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects): - -```{Rcpp, class.source = "rcppchunk", eval = FALSE} -class Parameter { - public: - double value; /**< initial value of the parameter*/ - //std::numeric_limits::min() returns a very large negative number - double min = - std::numeric_limits::min(); /**< min value of the parameter*/ - - //std::numeric_limits::max() returns a very large positive number - double max = - std::numeric_limits::max(); /**< max value of the parameter*/ - bool is_random_effect = false; /**< Is the parameter a random effect - parameter? Default value is false.*/ - bool estimated = - false; /**< Is the parameter estimated? Default value is false.*/ - ... - } -``` -The fields from the `Parameter` class that are accessible from R are defined in the -[rcpp_interface.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_interface.hpp) file in the directory [inst/include/interface/rcpp](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp): +All Rcpp interface classes from FIMS define parameters (e.g., `inflection_point`, `slope`) using the `ParameterVector` class defined in [rcpp_interface_base.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_interface_base.hpp) in the directory [inst/include/interface/rcpp/rcpp_objects](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects). ParameterVectors allow parameters to vary with time. Whereas, the Parameter class is only used for time-invariant parameters. The fields for these classes that are accessible from R are defined in the +[rcpp_interface.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_interface.hpp) file in the directory [inst/include/interface/rcpp](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp). For example, ```{Rcpp, class.source = "rcppchunk", eval = FALSE} Rcpp::class_("Parameter") - .constructor() - .constructor() - .constructor() - .field("value", &Parameter::value) - .field("min", &Parameter::min) - .field("max", &Parameter::max) - .field("is_random_effect", &Parameter::is_random_effect) - .field("estimated", &Parameter::estimated); + .constructor() + .constructor() + .constructor() + .field("value", &Parameter::value) + .field("min", &Parameter::min) + .field("max", &Parameter::max) + .field("is_random_effect", &Parameter::is_random_effect) + .field("estimated", &Parameter::estimated); ``` -Each field (i.e., parameter) from `maturity` (i.e., the maturity module we defined in R) will therefore inherit the five fields defined in the Parameter class: `value`, `min`, `max`, `is_random_effect`, `estimated`. +Each field (i.e., parameter) from `maturity` (i.e., the maturity module we defined in R) will therefore inherit the five fields defined in the Parameter class: `value`, `min`, `max`, `is_random_effect`, `estimated`. That is, two parameter fields and 10 fields within those parameters. -## Linking the Rcpp interface to the fims namespace. +## `fims` namespace -### What is the `fims` namespace? +### What is a namespace? -A namespace in C++ is similar to what a library is in R. - -The core of FIMS is within the `fims` namespace and is a convenient way to differentiate between the part of the C++ code base that is portable, i.e., independent of statistical platform, and the part of the codebase that depends on platforms outside of base C++ (e.g., `{Rcpp}`, R, `{TMB}`). Any code written within: +A namespace in C++ is similar to a library in R. The core of FIMS is within the `fims` namespace and the namespace is a convenient way to differentiate between the part of the C++ code base that is portable, i.e., independent of statistical platform, and the part of the codebase that depends on platforms outside of base C++ (e.g., `{Rcpp}`, R, `{TMB}`). Any code written within: ```{Rcpp, class.source = "fimschunk", eval = FALSE} namespace fims{ @@ -186,25 +210,26 @@ namespace fims{ ``` is considered to be a part of the `fims` namespace. C++ classes written within the `fims` namespace can be accessed within the C++ code base using `fims_popdy::`. -There are some exceptions where `{TMB}` specific code is referenced within the `fims` namespace. In these cases, code is written within an `#ifdef TMB_MODEL` wrapper, which means the code is only defined if `{TMB}` is being used. Given the addition of a new platform, eg. stan, a new wrapper could be added to define platform specific code for these sections. +There are some exceptions where `{TMB}` specific code is referenced within the `fims` namespace. In these cases, code is written within an `#ifdef TMB_MODEL` wrapper, which means the code is only defined if `{TMB}` is being used. Given the addition of a new platform, e.g., stan, a new wrapper could be added to define platform specific code for these sections. + +For example, the definition of data types in [inst/include/interface/interface.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/interface.hpp) will always be platform dependent because each platform has specific requirements for how the data types are defined. Whenever a new platform is added to `{FIMS}`, we will need to set up the platform specific data type definitions. Below is an example of a definition. -For example, the definition of data types in [interface.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/interface.hpp) in the directory [inst/include/interface](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface) will always be platform dependent as each platform has specific requirements for how the data types are defined. Whenever a new platform is added to `{FIMS}`, we will need to set up the platform specific data type definitions: ```{Rcpp, class.source = "fimschunk", eval = FALSE} namespace fims { #ifdef TMB_MODEL /** - * @brief fims::ModelTraits class that contains the DataVector + * @brief fims::ModelTraits class that contains the DataVector * and ParameterVector types. */ template struct fims::ModelTraits { - typedef typename CppAD::vector DataVector; /**< This is a vector + typedef typename CppAD::vector DataVector; /**< A vector of the data that is differentiable */ - typedef typename CppAD::vector ParameterVector; /**< This is a + typedef typename CppAD::vector ParameterVector; /**< A vector of the parameters that is differentiable */ typedef typename tmbutils::vector - EigenVector; /**< This is a vector as defined in TMB's namespace Eigen */ + EigenVector; /**< A vector as defined in the Eigen namespace in TMB */ }; #endif /* TMB_MODEL */ } // namespace fims @@ -215,89 +240,83 @@ struct fims::ModelTraits { #endif ``` -### Getting back to the maturity example... -Each Rcpp interface object includes an `add_to_fims_tmb()` function. There are two shared pointers set up within this function, one to link each Rcpp interface object (e.g., LogisticMaturityInterface) to the `Information` class in the `fims` namespace defined in [information.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/information.hpp) in the directory [inst/include/common](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/common) and one to link to the matching class in the `fims` namespace. In our maturity example, this would be the `LogisticMaturity` class in the `fims` namespace defined in [logistic.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/maturity/functors/logistic.hpp) in the directory [inst/include/population_dynamics/maturity/functors](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/population_dynamics/maturity/functors). +### Maturity example +Each Rcpp interface object includes an `add_to_fims_tmb()` function. There are two shared pointers set up within this function, one to link each Rcpp interface object (e.g., `LogisticMaturityInterface`) to the `Information` class in the `fims` namespace defined in [inst/include/common/information.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/information.hpp) and one to link to the matching class in the `fims` namespace. In our maturity example, this would be the `LogisticMaturity` class in the `fims` namespace defined in [inst/include/population_dynamics/maturity/functors/logistic.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/maturity/functors/logistic.hpp). -Within the rcpp_maturity.hpp file, we can link to the `fims_info::Information` class in order to register maturity parameters and specify whether or not they are random effects. We do this by setting up two pointers in the interface: d0 which points to information, and lm0, which points to the logistic maturity module. +Within rcpp_maturity.hpp, there is a link to the `fims_info::Information` class to register maturity parameters and specify whether or not they are random effects. We do this by setting up two pointers in the interface, info that points to information, and maturity that points to the logistic maturity module. ```{Rcpp, class.source = "rcppchunk", eval = FALSE} -//file: rcpp_maturity.hpp +// file: rcpp_maturity.hpp -//d0 is a shared pointer that points to fims_info::Information -std::shared_ptr > d0 = +// info is a shared pointer that points to fims_info::Information +std::shared_ptr > info = fims_info::Information::GetInstance(); if (this->inflection_point.estimated) { if (this->inflection_point.is_random_effect) { /* if inflection_point is estimated and a random effect, - the inflection_point value from LogisticMaturityInterface (lm0->inflection_point) + the inflection_point value from LogisticMaturityInterface (maturity->inflection_point) is passed to the Information member function RegisterRandomEffect */ - d0->RegisterRandomEffect(lm0->inflection_point); + info->RegisterRandomEffect(maturity->inflection_point); } else { /* if inflection_point is estimated and not a random effect, - the inflection_point value from LogisticMaturityInterface (lm0->inflection_point) + the inflection_point value from LogisticMaturityInterface (maturity->inflection_point) is passed to the Information member function RegisterParameter */ - d0->RegisterParameter(lm0->inflection_point); + info->RegisterParameter(maturity->inflection_point); } } ``` +Linking to the `fims_popdy::LogisticMaturity` class allows the code to link the values input from R to the values used in the estimation of parameters when fitting data to a model. Below is an example of the link for maturity. -Linking to the `fims_popdy::LogisticMaturity` class allows us to link the values input from R with the values used in model calculation: ```{Rcpp, class.source = "rcppchunk", eval = FALSE} -//file: rcpp_maturity.hpp +// file: rcpp_maturity.hpp -//lm0 is a shared pointer that points to fims_popdy::LogisticMaturity -std::shared_ptr > lm0 = - std::make_shared >(); +// maturity is a shared pointer that points to fims_popdy::LogisticMaturity +std::shared_ptr > maturity = + std::make_shared >(); -/* - the inflection_point value from LogisticMaturity (lm0->inflection_point) - equals the inflection_point value from LogisticMaturityInterface (this->inflection_point.value) - */ -lm0->inflection_point = this->inflection_point.value; +// the inflection_point value from LogisticMaturity (maturity->inflection_point) +// equals the inflection_point value from LogisticMaturityInterface +// (this->inflection_point.value) +maturity->inflection_point = this->inflection_point.value; ``` We can also link these two pointers together so that the **fims_info::Information** class links up with the **fims_popdy::LogisticMaturity**, but more details on this later. ```{Rcpp, class.source = "rcppchunk", eval = FALSE} -//file: rcpp_maturity.hpp +// file: rcpp_maturity.hpp -/* - the maturity_models pointer from Information that matches the - id of the fims_popdy::LogisticMaturity class is equal to the pointer - to fims_popdy::LogisticMaturity - */ -d0->maturity_models[lm0->id] = lm0; +// the maturity_models pointer from Information that matches the +// id of the fims_popdy::LogisticMaturity class is equal to the pointer +// to fims_popdy::LogisticMaturity +info->maturity_models[maturity->id] = maturity; ``` - -The $\color{#c55a11}{\text{`add_to_fims_tmb()`}}$ function repeats code four times to track the estimated value of parameters along with their first, second, and third derivatives. - +The $\color{#c55a11}{\text{`add_to_fims_tmb()`}}$ function repeats `add_to_fims_tmb_internal` four times to track the estimated value of each parameter along with their first, second, and third derivatives. ```{r image-path-maturity-2, echo = FALSE, message=FALSE, out.width = '100%'} knitr::include_graphics("figures/fims-path-maturity-2.png") ``` +## `fims_popdy::LogisticMaturity` class -## Inside the `fims_popdy::LogisticMaturity` class - -The `LogisticMaturity` class in the `fims` namespace defined in [logistic.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/maturity/functors/logistic.hpp) in the directory [inst/include/population_dynamics/maturity/functors](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/population_dynamics/maturity/functors) has an `evaluate` method (i.e., function) that takes an input, *x* and returns the output from a logistic function (defined in [fims_math.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/fims_math.hpp) in the directory [inst/include/common](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common)) using the class member `inflection_point` and `slope` values. +The `LogisticMaturity` class in the `fims` namespace defined in [inst/include/population_dynamics/maturity/functors/logistic.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/maturity/functors/logistic.hpp) has an `evaluate` method (i.e., function) that takes an input, *x* and returns the output from a logistic function (defined in [inst/include/common/fims_math.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/fims_math.hpp)) using the class members `inflection_point` and `slope` values. Other modules that use the logistic function use the same function in fims_math.hpp, e.g., logistic selectivity, and thus, the logistic equation is only defined once within the source code but used for multiple modules. ```{Rcpp, class.source = "fimschunk", eval = FALSE} namespace fims_popdy { /** - * @brief LogisticMaturity class that returns the logistic function value + * @brief LogisticMaturity class that returns the logistic function value * from fims_math. */ template struct LogisticMaturity : public MaturityBase { - Type inflection_point; /**< 50% quantile of the value of the quantity of interest (x); e.g., - age at which 50% of the fish are mature */ + Type inflection_point; /**< 50 percent quantile of the value of the quantity of interest (x); e.g., + age at which 50 percent of the fish are mature */ Type slope; /** { * @brief Method of the logistic maturity class that implements the * logistic function from FIMS math. * - * @param x The independent variable in the logistic function (e.g., age or + * @param x The independent variable in the logistic function (e.g., age or * size at maturity). */ virtual const Type evaluate(const Type& x) { @@ -322,33 +341,44 @@ struct LogisticMaturity : public MaturityBase { knitr::include_graphics("figures/fims-path-maturity-3.png") ``` -## Calling maturity from population +## Population class -The `Population` class defined in [population.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/population/population.hpp) in the directory [inst/include/population_dynamics/population](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/population) is where all the biological calculations happen, producing expected values used in likelihood equations and derived values important for management (e.g., spawning biomass). - -To evaluate maturity within the `Population` class, we first need to set up a shared pointer, linking the maturity module to population. +The `Population` class defined in [inst/include/population_dynamics/population/population.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/population_dynamics/population/population.hpp) is where all the biological calculations happen, producing expected values used in likelihood equations and derived quantities that are important for management (e.g., spawning biomass). A shared pointer that links the maturity module to population must be set up before the model can evaluate maturity within the `Population` class. ```{Rcpp, class.source = "fimschunk", eval = FALSE} -//file: inst/include/population_dynamics/population/population.hpp +// file: inst/include/population_dynamics/population/population.hpp // maturity is a shared pointer to MaturityBase -int maturity_id = -999; /**< id of maturity model object*/ -std::shared_ptr> - maturity; /**< shared pointer to maturity module */ + +// id of the maturity model object +int maturity_id = -999; +// shared pointer to the maturity module +std::shared_ptr> maturity; ``` -The `maturity_id` was set from R using the `SetMaturity()` method from the `PopulationInterface` class: +The `maturity_id` was set from R using the `SetMaturity()` method from the `PopulationInterface` class, which as a reminder is done internally within `FIMS::initialize_population` but can also be done by hand with `SetMaturity`. Where both options are shown, again, below. ```{r, class.source = "rchunk", eval = FALSE} +# Helper function +population <- FIMS:::initialize_population( + parameters = parameters, + data = fims_frame, + linked_ids = setNames( + c(maturity$get_id(), 2, 3), + c("maturity", "growth", "recruitment") + ) +) + +# Manual population$SetMaturity(maturity$get_id()) ``` -Notice above that population by default declares a pointer of type `MaturityBase` (parent class), not the specific maturity class we are using in this example, `LogisticMaturity` (child class). `MaturityBase` has an `evaluate` method with input arguments that match the inputs of each child class: +Notice above that population by default declares a pointer of type `MaturityBase` (parent class), not the specific maturity class we are using in this example, i.e., `LogisticMaturity` (child class). `MaturityBase` has an `evaluate` method with input arguments that match the inputs of each child class: ```{Rcpp, class.source = "fimschunk", eval = FALSE} -//file: inst/include/population_dynamics/maturity/functors/maturity_base.hpp +// file: inst/include/population_dynamics/maturity/functors/maturity_base.hpp namespace fims_popdy { -/** @brief Base class for all maturity functors. - * +/** + * @brief Base class for all maturity functors. * @tparam TypeThe type of the maturity functor. */ @@ -360,7 +390,8 @@ struct MaturityBase : public fims_model_object::FIMSObject { // all the instances of the MaturityBase class. static uint32_t id_g; /**< The ID of the instance of the MaturityBase class */ - /** @brief Constructor. + /** + * @brief Constructor */ MaturityBase() { // increment id of the singleton maturity class @@ -374,25 +405,27 @@ struct MaturityBase : public fims_model_object::FIMSObject { */ virtual const Type evaluate(const Type& x) = 0; }; + +} ``` -The evaluate function is a [virtual C++ function](https://www.geeksforgeeks.org/virtual-function-cpp/), which means the function can be overwritten by functions of the same name from a child class. This structure keeps the maturity module in population generic. We don't need any conditional statements to loop over all possible maturity formulations within population. We only need to add a new child maturity class with an Rcpp interface and we can automatically call it from population. There is a trade-off here. We are creating a nested hierarchical structure that makes the code base harder to read. In exchange, we're creating code with a lower [cyclomatic complexity](https://en.wikipedia.org/wiki/Cyclomatic_complexity), that is there will only ever be one independent path from the user to the maturity->evaluate() call in population, regardless of how many maturity functions are added to FIMS. Code with lower cyclomatic complexity is easier to test, maintain, and extend. +The evaluate function is a [virtual C++ function](https://www.geeksforgeeks.org/virtual-function-cpp/), which means the function can be overwritten by functions of the same name from a child class. This structure keeps the maturity module in population generic. We don't need any conditional statements to loop over all possible maturity formulations within population. We only need to add a new child maturity class with an Rcpp interface and we can automatically call it from population. There is a trade-off here. We are creating a nested hierarchical structure that makes the code base harder to read. In exchange, we're creating code with a lower [cyclomatic complexity](https://en.wikipedia.org/wiki/Cyclomatic_complexity), that is, there will only ever be one independent path from the user to the `maturity->evaluate()` call in population, regardless of how many maturity functions are added to FIMS. Code with lower cyclomatic complexity is easier to test, maintain, and extend. -Once we've set up the shared pointer, we can access maturity from within population: +Once we have set up the shared pointer, we can access maturity from within population. ```{Rcpp, class.source = "fimschunk", eval = FALSE} -//file: inst/include/population_dynamics/population/population.hpp +// file: inst/include/population_dynamics/population/population.hpp /** - * @brief Calculates expected proportion of individuals mature at a selected - * age - * - * @param i_age_year dimension folded index for age and year - * @param age the age of maturity - */ + * @brief Calculates expected proportion of individuals mature at a selected + * age. + * + * @param i_age_year dimension folded index for age and year + * @param age the age of maturity + */ void CalculateMaturityAA(size_t i_age_year, size_t age) { // this->maturity is pointing to the maturity module, which has - // an evaluate function. -> can be nested. + // an evaluate function. -> can be nested. this->proportion_mature_at_age[i_age_year] = - this->maturity->evaluate(ages[age]); + this->maturity->evaluate(ages[age]); } ``` @@ -401,47 +434,43 @@ Once we've set up the shared pointer, we can access maturity from within populat knitr::include_graphics("figures/fims-path-maturity-4.png") ``` -## Linking everything together +## Overview -The above material demonstrates how values passed in from R get propagated into population.hpp, where they are used in biologically relevant calculations. This, however, relies on population referencing the correct child class (eg. `LogisticMaturity`) even though it only calls the parent class (`MaturityBase`). We defined the `maturity_id` in population for the specific logistic maturity module we wanted to use, `population$SetMaturity(maturity$get_id())`, but we still need to connect this ID with the actual module in memory. +The above material demonstrates how values passed in from R are propagated into population.hpp, where they are used in biologically relevant calculations. This, however, relies on population referencing the correct child class (e.g., `LogisticMaturity`) even though it only calls the parent class (`MaturityBase`). We defined the `maturity_id` in population for the specific logistic maturity module we wanted to use, `population$SetMaturity(maturity$get_id())`, but we still need to connect this ID with the actual module in memory. -This *information* is managed in FIMS through the `Information` class in [information.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/information.hpp) in the directory [inst/include/common](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/common). The Information class sets up a number of [C++ maps](https://cplusplus.com/reference/map/map/) (a container with a key value and mapped value - think of named lists in R) where the key is the unique ID to the module and the mapped value is a shared pointer to the module. C++ std::maps have an iterator member for stepping through the elements of the map. This iterator is also declared in the Information class so that we can loop through all the unique maturity modules being called in FIMS. We currently only have one, but if FIMS gets extended to include multiple populations, we could have a unique maturity module for each population or subset of populations. +This *information* is managed in FIMS through the `Information` class in [inst/include/common/information.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/common/information.hpp). The Information class sets up a number of [C++ maps](https://cplusplus.com/reference/map/map/) (a container with a key value and mapped value - think of named lists in R) where the key is the unique ID to the module and the mapped value is a shared pointer to the module. C++ `std::maps` have an iterator member for stepping through the elements of the map. This iterator is also declared in the Information class so that we can loop through all the unique maturity modules being called in FIMS. We currently only have one but if FIMS is ever extended to include multiple populations, we could have a unique maturity module for each population or subset of populations. ```{Rcpp, class.source = "infochunk", eval = FALSE} -//file: inst/include/common/information.hpp -/* - uint32_t is an unsigned integer (always positive) - The first component of the map is a uint32_t which - will be used to hold the ID. - The second component of the map is the shared pointer, - maturity_models, that points to fims_popdy::MaturityBase - */ +// file: inst/include/common/information.hpp +// uint32_t is an unsigned integer (always positive) +// The first component of the map is a uint32_t which will be used to hold the +// ID. The second component of the map is the shared pointer, maturity_models, +// that points to fims_popdy::MaturityBase + +// hash map to link each object to its shared location in memory std::map > > - maturity_models; /** > >::iterator - maturity_models_iterator; + maturity_models_iterator; ``` ```{r image-path-maturity-5, echo = FALSE, message=FALSE, out.width = '100%'} knitr::include_graphics("figures/fims-path-maturity-5.png") ``` -Next, let's revisit the line of code that was written in the Rcpp `LogisticMaturityInterface` class in [rcpp_maturity.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp) in the directory [inst/include/interface/rcpp/rcpp_objects](https://github.com/NOAA-FIMS/FIMS/tree/main/inst/include/interface/rcpp/rcpp_objects) +Next, let's revisit the line of code that was written in the Rcpp `LogisticMaturityInterface` class in [inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp](https://github.com/NOAA-FIMS/FIMS/blob/main/inst/include/interface/rcpp/rcpp_objects/rcpp_maturity.hpp). Here, we are setting the maturity_models pointer in `Information` to equal the `maturity` pointer to the `LogisticMaturity` module. -Here, we are setting the maturity_models pointer in `Information` to equal the `lm0` pointer to the `LogisticMaturity` module ```{Rcpp, class.source = "rcppchunk", eval = FALSE} -//file: rcpp_maturity.hpp +// file: rcpp_maturity.hpp -/* - the maturity_models pointer from Information that matches the id of the - fims_popdy::LogisticMaturity class is equal to the pointer to fims_popdy::LogisticMaturity - */ -d0->maturity_models[lm0->id] = lm0; +// the maturity_models pointer from Information that matches the id of the +// fims_popdy::LogisticMaturity class is equal to the pointer to +// fims_popdy::LogisticMaturity +info->maturity_models[maturity->id] = maturity; ``` ```{r image-path-maturity-6, echo = FALSE, message=FALSE, out.width = '100%'} @@ -450,48 +479,52 @@ knitr::include_graphics("figures/fims-path-maturity-6.png") Now we need to pass this pointer to the maturity pointer in population so that `population->maturity` points to the `LogisticMaturity` module instead of `MaturityBase`. First we set up a map in `Information` that points to `Population`. ```{Rcpp, class.source = "infochunk", eval = FALSE} -//file: inst/include/common/information.hpp -std::map > > - populations; /** > > populations; typedef typename std::map > >::iterator - population_iterator; - /**< iterator for population objects>*/ + population_iterator; +// iterator for population objects ``` ```{r image-path-maturity-7, echo = FALSE, message=FALSE, out.width = '100%'} knitr::include_graphics("figures/fims-path-maturity-7.png") ``` -We then loop through the populations and create a new shared pointer, `p`, to reference the individual population of interest. +Populations are looped through with a new shared pointer, `p`, to reference the individual population of interest. ```{Rcpp, class.source = "infochunk", eval = FALSE} -//file: inst/include/common/information.hpp - for (population_iterator it = this->populations.begin(); - it != this->populations.end(); ++it) { - std::shared_ptr > p = (*it).second; - ... +// file: inst/include/common/information.hpp +for (population_iterator it = this->populations.begin(); + it != this->populations.end(); ++it) { + std::shared_ptr > p = (*it).second; + ... +} ``` -In this code chunk, `(*it)` refers to a single population in the `populations` map. The second element of the map is the pointer, so `p = (*it).second` means we are setting the pointer to a single population to equal the pointer to `populations` in the map. -Within this population loop, we then link the `maturity` pointer in `population` to equal the `maturity` pointer in information, passing on the information that we want to use the `LogisticMaturity` class: +In this code chunk, `(*it)` refers to a single population in the `populations` map. The second element of the map is the pointer, so `p = (*it).second` means the pointer is being set to a single population to equal the pointer to `populations` in the map. + +Within this population loop, the `maturity` pointer in `population` is linked to the `maturity` pointer in information, passing on the information that we want to use the `LogisticMaturity` class. ```{Rcpp, class.source = "infochunk", eval = FALSE} -//file: inst/include/common/information.hpp +// file: inst/include/common/information.hpp // set maturity if (p->maturity_id != -999) { uint32_t maturity_uint = static_cast(p->maturity_id); - maturity_models_iterator it = this->maturity_models.find( - maturity_uint); // >maturity_models is specified in - // information.hpp and used in rcpp + maturity_models_iterator it = this->maturity_models.find(maturity_uint); + // >maturity_models is specified in + // information.hpp and used in rcpp if (it != this->maturity_models.end()) { - //p->maturity is the maturity pointer in population - p->maturity = - //(*it).second is the maturity pointer in information - (*it).second; // >maturity defined in population.hpp + // p->maturity is the maturity pointer in population + // (*it).second is the maturity pointer in information + p->maturity = (*it).second; // >maturity defined in population.hpp } + + } ``` Here, (\*it) is referring to the `maturity_models` map in information and (\*it).second refers to the second element of the map, which is the pointer to the maturity module. @@ -500,18 +533,13 @@ Here, (\*it) is referring to the `maturity_models` map in information and (\*it) knitr::include_graphics("figures/fims-path-maturity-8.png") ``` +## Thinking in R -## Conceptualizing this path with R -This is an optional exercise for those who benefit from thinking through the structure in C++ code by seeing its corollary in R. - -Let's think about writing something similar in R using lists for three populations and two maturity functions. Each R code section corresponds with C++ code taken from FIMS. These FIMS sections will be commented out to help distinguish between the two code sets. The idea is to link what is happening in FIMS to a language we're all a bit more familiar with. +This is an optional exercise for those who would benefit from reviewing what is happening when the Rcpp code is being accessed from within R and how to translate some of the C++ code into similar R code. Below, the first section of code will be how to think about a concept in R and the second section will be how to use Rcpp in R or how to think about the C++ code in R terms. These latter sections, will be commented out to help distinguish between the two code sets. The idea is to link what is happening in the C++ code of FIMS to a language that some are more familiar with, i.e., R. -Example Case: -Let's set up 3 populations where the first two have a mirrored logistic maturity function and the third has a different maturity function. This third function could be a different function all together or a logistic function with a different parameter set. For this example, we'll use a logistic function with a different parameter set. +Of the three populations included in the example, the first two have a mirrored logistic maturity function and the third has a different maturity function. This third function could be a different function all together or a logistic function with a different parameter set. For this example, there the third maturity function is a logistic function with a different parameter set. Note that additional modules should be included in population, e.g., growth, but that will be ignored for this example. ```{r} -# For the population module, there are additional parameters -# we are going to ignore here population_modules <- list( "Pop 1" = list( id = 1, @@ -532,49 +560,43 @@ maturity_modules <- list( ) ``` -We can think of population_modules and maturity_modules above as instantiated C++ classes stored in our computer's memory. This R code chunk above is comparable to the following from FIMS, which sets up modules in R: +`population_modules` and `maturity_modules` are the equivalent of instantiated C++ classes stored in memory. This R code chunk above is comparable to using Rcpp in R to set up the modules and store them in memory. ```{r, eval = FALSE} -# maturity1 <- new(LogisticMaturity) +# maturity1 <- methods::new(LogisticMaturity) # maturity1$inflection_point$value <- 10 # maturity1$slope$value <- 0.2 -# maturity2 <- new(LogisticMaturity) +# maturity2 <- methods::new(LogisticMaturity) # maturity2$inflection_point$value <- 8 # maturity2$slope$value <- 0.3 -# population1 <- new(Population) -# population2 <- new(Population) -# population3 <- new(Population) +# population1 <- methods::new(Population) +# population2 <- methods::new(Population) +# population3 <- methods::new(Population) ``` -Next we assign which maturity will be used with each population using IDs +Next, the maturity IDS are assigned to each `maturity_id` in one of the three populations. Which is actually done using `SetMaturity` in R (i.e., the commented out code). ```{r} population_modules[[1]]$maturity_id <- maturity_modules[[1]]$id population_modules[[2]]$maturity_id <- maturity_modules[[1]]$id population_modules[[3]]$maturity_id <- maturity_modules[[2]]$id -``` -This R code chunk above is comparable to the following from FIMS, which sets IDs in R: -```{r, eval = FALSE} # population1$SetMaturity(maturity1$get_id()) # population2$SetMaturity(maturity1$get_id()) # population3$SetMaturity(maturity2$get_id()) ``` -Now let's review what is happening in Information. We'll start by setting up an empty list in R. +In FIMS, the Information class has the objects, population and maturity, which are C++ maps. The first element of the map is the ID, the second element of the map is the pointer to the Population or Maturity class. This can be thought about in R using a list but in C++ maps are used. ```{r} information <- list( populations = list(id = NULL, pointer = "Population"), maturity = list(id = NULL, pointer = "MaturityBase") ) -``` -In FIMS, the Information class has the objects, population and maturity, which are C++ maps. The first element of the map is the ID, the second element of the map is the pointer to the Population or Maturity class: -```{r, eval = FALSE} # std::map > > maturity_models; # std::map > > populations; ``` -We can then link up the pointers in information to each respective module: +Pointers are used to link Information to each respective module. ```{r} information$populations[[1]] <- list(id = 1, pointer = population_modules[[1]]) @@ -585,21 +607,19 @@ information$maturity[[1]] <- list(id = 1, pointer = maturity_modules[[1]]) information$maturity[[2]] <- list(id = 2, pointer = maturity_modules[[2]]) ``` -In FIMS, these definitions happen by passing information from the rcpp interface into FIMS Information. +In FIMS, these definitions happen by passing information from the rcpp interface into FIMS Information in rcpp_maturity.hpp, where `info` in the pointer to information and `maturity` is the pointer to a specific maturity module. + ```{r, class.source = "rcppchunk", eval = FALSE} -## //file: rcpp_maturity.hpp -## d0 is the pointer to information -## lm0 is the pointer to a specific maturity module -## (e.g., lm0 = maturity_modules[[1]]) -# d0->maturity_models[lm0->id] = lm0; +## // (e.g., maturity = maturity_modules[[1]]) +# info->maturity_models[maturity->id] = maturity; ``` -We can then loop through each population module defined in information and set the maturity we're getting from the user specified in the Rcpp interface back out to the Population class used to run all the calculations in the model. After each line of code in the following chunk, corresponding C++ code from FIMS is directly below and commented out. +Each population module that is defined in `information` must be looped through to set the maturity defined in the user-specified Rcpp interface back out to the Population class used to run all the calculations in the model. ```{r} for (it in 1:length(population_modules)) { # for (population_iterator it = this->populations.begin(); - # it != this->populations.end(); ++it) { + # it != this->populations.end(); ++it) { p <- information$populations[[it]][2] # std::shared_ptr > p = (*it).second; @@ -607,7 +627,9 @@ for (it in 1:length(population_modules)) { maturity_uint <- p$pointer$maturity_id # uint32_t maturity_uint = static_cast(p->maturity_id); - newit <- which(sapply(information$maturity, function(x) x$id) == maturity_uint) + newit <- which( + sapply(information$maturity, function(x) x$id) == maturity_uint + ) # maturity_models_iterator it = this->maturity_models.find(maturity_uint) p$pointer$maturity # MaturityBase @@ -621,9 +643,6 @@ for (it in 1:length(population_modules)) { sapply(population_modules, function(x) x[2]$maturity) ``` -In R, the above code sets up an intermediate value, p. Once we update the maturity from p to equal the correct maturity module, `p$pointer$maturity <- information$maturity[[newit]][[2]]`, the above code passes this back to population_modules, `population_modules[[it]][2]$maturity <- p$pointer$maturity`. In this context, `population_modules` is the population class held in memory that is being used to run calculations. +In R, the above code sets up an intermediate value, `p`. Once maturity from p is updated to equal the correct maturity module, `p$pointer$maturity <- information$maturity[[newit]][[2]]`, the above code passes this back to population_modules, `population_modules[[it]][2]$maturity <- p$pointer$maturity`. In this context, `population_modules` is the population class held in memory that is being used to run calculations. The deeper level of abstraction happening in C++ is that in FIMS, _p is the population module_ stored in memory. An equivalent line of code to `population_modules[[it]][2]$maturity <- p$pointer$maturity` isn't needed in FIMS because when we update p, we are also updating the population class held in memory that is being used to run calculations. - - -