From b401c61c9a5dcea3059c43750a523bd58e02af8b Mon Sep 17 00:00:00 2001 From: Bai-Li-NOAA Date: Wed, 18 Dec 2024 14:35:58 -0500 Subject: [PATCH] fix failed tests * set survey_fleet[1] <- TRUE to estimate q. TODO:remove estimate_q from fleet module? * update initialize_modules() to remove settings for nlengths when no length composition data are provided * update fims-demo to show models runs with both age comp and length comp data --- R/initialize_modules.R | 7 +- .../testthat/helper-integration-tests-setup.R | 115 +------------ tests/testthat/test-initialize_modules.R | 3 +- ...ntegration-fims-estimation-with-wrappers.R | 160 ++++-------------- ...gration-fims-estimation-without-wrappers.R | 4 +- 5 files changed, 43 insertions(+), 246 deletions(-) diff --git a/R/initialize_modules.R b/R/initialize_modules.R index 9a8cb865..fc55a1a8 100644 --- a/R/initialize_modules.R +++ b/R/initialize_modules.R @@ -106,12 +106,15 @@ initialize_module <- function(parameters, data, module_name) { 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", - # Right now we can also remove nlengths because the default is 0 - # "nlengths", "proportion_catch_numbers_at_length" )) } diff --git a/tests/testthat/helper-integration-tests-setup.R b/tests/testthat/helper-integration-tests-setup.R index 3168a1e3..0b742e35 100644 --- a/tests/testthat/helper-integration-tests-setup.R +++ b/tests/testthat/helper-integration-tests-setup.R @@ -169,6 +169,7 @@ setup_and_run_FIMS_without_wrappers <- function(iter_id, 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$SetSelectivity(survey_fleet_selectivity$get_id()) @@ -382,111 +383,6 @@ setup_and_run_FIMS_with_wrappers <- function(iter_id, # Clear any previous FIMS settings clear() - # Set up data - # cv_2_sd <- function(x) { - # sqrt(log(x^2 + 1)) - # } - # - # landings_data <- data.frame( - # type = "landings", - # name = names(returnedom[["om_output"]]$L.mt)[1], - # age = NA, - # 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]]) - # ) - # - # 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_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" - # ) - # - # 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) - # - # data_dataframe <- type.convert( - # rbind(landings_data, index_data, age_data, weightatage_data), - # as.is = TRUE - # ) - # - # data <- FIMS::FIMSFrame(data_dataframe) data <- FIMS::FIMSFrame(data1) # Set up default parameters @@ -495,16 +391,14 @@ setup_and_run_FIMS_with_wrappers <- function(iter_id, selectivity = list(form = "LogisticSelectivity"), data_distribution = c( Index = "DlnormDistribution", - AgeComp = "DmultinomDistribution", - LengthComp = "DmultinomDistribution" + AgeComp = "DmultinomDistribution" ) ), survey1 = list( selectivity = list(form = "LogisticSelectivity"), data_distribution = c( Index = "DlnormDistribution", - AgeComp = "DmultinomDistribution", - LengthComp = "DmultinomDistribution" + AgeComp = "DmultinomDistribution" ) ) ) @@ -530,8 +424,7 @@ setup_and_run_FIMS_with_wrappers <- function(iter_id, 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), - Fleet.log_q.estimated = FALSE + Fleet.log_q.value = log(om_output$survey_q$survey1) ), recruitment = list( BevertonHoltRecruitment.log_rzero.value = log(om_input$R0), diff --git a/tests/testthat/test-initialize_modules.R b/tests/testthat/test-initialize_modules.R index 18c704c9..1a9b2b53 100644 --- a/tests/testthat/test-initialize_modules.R +++ b/tests/testthat/test-initialize_modules.R @@ -5,7 +5,8 @@ fleet1 <- survey1 <- list( selectivity = list(form = "LogisticSelectivity"), data_distribution = c( Index = "DlnormDistribution", - AgeComp = "DmultinomDistribution" + AgeComp = "DmultinomDistribution", + LengthComp = "DmultinomDistribution" ) ) diff --git a/tests/testthat/test-integration-fims-estimation-with-wrappers.R b/tests/testthat/test-integration-fims-estimation-with-wrappers.R index 32f4c732..a038a911 100644 --- a/tests/testthat/test-integration-fims-estimation-with-wrappers.R +++ b/tests/testthat/test-integration-fims-estimation-with-wrappers.R @@ -1,67 +1,5 @@ load(test_path("fixtures", "integration_test_data.RData")) -fleets <- list( - fleet1 = list( - selectivity = list(form = "LogisticSelectivity"), - data_distribution = c( - Index = "DlnormDistribution", - AgeComp = "DmultinomDistribution" - ) - ), - survey1 = list( - selectivity = list(form = "LogisticSelectivity"), - data_distribution = c( - Index = "DlnormDistribution", - AgeComp = "DmultinomDistribution" - ) - ) -) - -data("data1") -fims_data <- FIMS::FIMSFrame(data1) -default_parameters <- data1 |> - FIMS::FIMSFrame() |> - 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 <- default_parameters |> - update_parameters( - modified_parameters = modified_parameters - ) - test_that("deterministic test of fims", { iter_id <- 1 @@ -293,77 +231,14 @@ test_that("estimation test of fims using wrapper functions", { ) }) -test_that("estimation test of fims using high-level wrappers", { +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]] - # Clear any previous FIMS settings - clear() - parameter_list <- initialize_fims( - parameters = parameters, - data = fims_data - ) - input <- list() - input$parameters <- parameter_list - input$version <- "Model Comparison Project example" - fit <- fit_fims(input, 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 high-level 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]] - - # Update the number of length bins in the OM input for the current iteration - # This extracts the number of lengths from the FIMS data and assigns it to the - # operating model's input list. - # TODO: we can remove the code below after simulating 100 sets of length comp data in the - # tests/testthat/fixtures/simulate-integration-test-data.R - om_input_list[[iter_id]]$nlengths <- n_lengths(fims_data) - - # Update length composition data for the fishing fleet in the em input using the FIMS data1 - # This extracts a vector of observed length compositions for fleet1 from the FIMS data1 - # and assigns it to the estimation model's input list. - em_input_list[[iter_id]]$L.lengthcomp.obs$fleet1 <- m_lengthcomp(fims_data, "fleet1") - # Extract sample size for the length composition data of the fishing fleet - # This pulls the uncertainty column for "fleet1" with a "length" type from the FIMS data. - em_input_list[[iter_id]]$n.L.lengthcomp$fleet1 <- dplyr::filter( - .data = as.data.frame(get_data(fims_data)), - name == "fleet1", - type == "length" - ) |> - dplyr::pull(uncertainty) - # Update age-to-length conversion vector for the fishing fleet in the em input using the FIMS data1 - # This extracts age-to-length conversion values for fleet1 from the FIMS data1 - # and assigns it to the estimation model's input list. - em_input_list[[iter_id]]$L.age_to_length_conversion$fleet1 <- FIMS::m_age_to_length_conversion(fims_data, "fleet1") - - # Repeat similar setup for the survey fleet - em_input_list[[iter_id]]$survey.lengthcomp.obs$survey1 <- m_lengthcomp(fims_data, "survey1") - em_input_list[[iter_id]]$n.survey.lengthcomp$survey1 <- dplyr::filter( - .data = as.data.frame(get_data(fims_data)), - name == "survey1", - type == "length" - ) |> - dplyr::pull(uncertainty) - em_input_list[[iter_id]]$survey.age_to_length_conversion$survey1 <- FIMS::m_age_to_length_conversion(fims_data, "survey1") + fims_data <- FIMS::FIMSFrame(data1) # Clear any previous FIMS settings clear() @@ -387,8 +262,7 @@ test_that("estimation test with length comp using high-level wrappers",{ ) ) - lengthcomp_parameters <- data1 |> - FIMS::FIMSFrame() |> + lengthcomp_parameters <- fims_data |> create_default_parameters( fleets = fleets, recruitment = list( @@ -399,7 +273,33 @@ test_that("estimation test with length comp using high-level wrappers",{ maturity = list(form = "LogisticMaturity") ) - parameters <- default_parameters |> + 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 ) diff --git a/tests/testthat/test-integration-fims-estimation-without-wrappers.R b/tests/testthat/test-integration-fims-estimation-without-wrappers.R index 39b513aa..0f913204 100644 --- a/tests/testthat/test-integration-fims-estimation-without-wrappers.R +++ b/tests/testthat/test-integration-fims-estimation-without-wrappers.R @@ -67,7 +67,7 @@ test_that("deterministic test of fims", { report <- result$report # Compare log(R0) to true value - fims_logR0 <- sdr_fixed[35, "Estimate"] + fims_logR0 <- sdr_fixed[36, "Estimate"] expect_gt(fims_logR0, 0.0) expect_equal(fims_logR0, log(om_input_list[[iter_id]]$R0)) @@ -205,7 +205,7 @@ test_that("nll test of fims", { sdr_fixed <- result$sdr_fixed # log(R0) - fims_logR0 <- sdr_fixed[35, "Estimate"] + 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))