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
NOAA-FIMS · Dec 19, 2024 · b401c61 · b401c61
1 parent 8e81016
commit b401c61
Show file tree

Hide file tree

Showing 5 changed files with 43 additions and 246 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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))