From 70a30f15942f1451fe9edff376267518d90afda3 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Wed, 4 Nov 2026 15:31:27 -0500 Subject: [PATCH 01/17] feat: convert multiple models into standard stockplotr format pass a list of model files and get back a single tibble object of all models concatenated together --- R/convert_output.R | 448 +++++++++++++++++++++++---------------------- 1 file changed, 230 insertions(+), 218 deletions(-) diff --git a/R/convert_output.R b/R/convert_output.R index 62bda5b8..d09c3e79 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -43,194 +43,247 @@ #' ) #' } convert_output <- function( - file, - model = NULL, + files, + models = NULL, fleet_names = NULL, save_dir = NULL ) { - if (is.character(file) && grepl("Report.sso", file)) { - lifecycle::deprecate_warn( - when = "2.8.0", - what = I("convert_output(file = 'Report.sso')"), - details = c( - i = "Please use the returned object from `r4ss::ss_output()`", - i = "File will be compatible until Oct. 1, 2027" + processed <- purrr::imap(files, function(file, model_name){ + if (is.character(file) && grepl("Report.sso", file)) { + lifecycle::deprecate_warn( + when = "2.8.0", + what = I("convert_output(file = 'Report.sso')"), + details = c( + i = "Please use the returned object from `r4ss::ss_output()`", + i = "File will be compatible until Oct. 1, 2027" + ) + ) + } + + # check if entered save_dir exists so doesn't waste user time finding this out at the end + if (!is.null(save_dir)) { + if (!grepl(".rda", save_dir)) { + cli::cli_alert("save_dir does not contain a file name. Saved output will be named `std_output.rda`.") + save_dir <- file.path(save_dir, "std_output.rda") + } + } + + #### out_new #### + # Blank dataframe and set up to mold output into + out_new <- data.frame( + module_name = NA, + label = NA, + time = NA, + era = NA, + year = NA, + month = NA, + season = NA, + subseason = NA, + birthseas = NA, + initial = NA, + estimate = NA, + uncertainty = NA, + uncertainty_label = NA, + likelihood = NA, + fleet = NA, + platoon = NA, + area = NA, + age = NA, + sex = NA, + growth_pattern = NA, + # gradient = NA, + # estimated = NA, # TRUE/FALSE + # Additional factors from SS3 + bio_pattern = NA, + settlement = NA, + morph = NA, + beg_mid = NA, + type = NA, + factor = NA, + # sexes = NA, # remove sexes to see how it impacts the results + part = NA, + kind = NA, + nsim = NA, + # TODO: add age_a and len_bins into just bins - add the age value in age + bin = NA, + age_a = NA, + len_bins = NA, + count = NA, + block = NA + # model_name = model_name ) - ) - } - - # check if entered save_dir exists so doesn't waste user time finding this out at the end - if (!is.null(save_dir)) { - if (!grepl(".rda", save_dir)) { - cli::cli_alert("save_dir does not contain a file name. Saved output will be named `std_output.rda`.") - save_dir <- file.path(save_dir, "std_output.rda") - } - } + out_new <- out_new[-1, ] - #### out_new #### - # Blank dataframe and set up to mold output into - out_new <- data.frame( - module_name = NA, - label = NA, - time = NA, - era = NA, - year = NA, - month = NA, - season = NA, - subseason = NA, - birthseas = NA, - initial = NA, - estimate = NA, - uncertainty = NA, - uncertainty_label = NA, - likelihood = NA, - fleet = NA, - platoon = NA, - area = NA, - age = NA, - sex = NA, - growth_pattern = NA, - # gradient = NA, - # estimated = NA, # TRUE/FALSE - # Additional factors from SS3 - bio_pattern = NA, - settlement = NA, - morph = NA, - beg_mid = NA, - type = NA, - factor = NA, - # sexes = NA, # remove sexes to see how it impacts the results - part = NA, - kind = NA, - nsim = NA, - # TODO: add age_a and len_bins into just bins - add the age value in age - bin = NA, - age_a = NA, - len_bins = NA, - count = NA, - block = NA - ) - out_new <- out_new[-1, ] + # Check if path links to a valid file + if (is.character(file)) { + url_pattern <- "^(https?|ftp|file):\\/\\/[-A-Za-z0-9+&@#\\/%?=~_|!:,.;]*[-A-Za-z0-9+&@#\\/%=~_|]$" + if (grepl(url_pattern, file)) { + check <- tryCatch( + { + headers <- curlGetHeaders(file) + attributes(headers)[["status"]] + }, + error = function(e) { + 404 + } + ) + if (check == 404) cli::cli_abort(c(message = "Invalid URL.")) + } else { + if (!file.exists(file)) { + cli::cli_abort(c( + message = "`file` not found.", + "i" = "`file` entered as {file}" + )) + } + } + } - # Check if path links to a valid file - if (is.character(file)) { - url_pattern <- "^(https?|ftp|file):\\/\\/[-A-Za-z0-9+&@#\\/%?=~_|!:,.;]*[-A-Za-z0-9+&@#\\/%=~_|]$" - if (grepl(url_pattern, file)) { - check <- tryCatch( - { - headers <- curlGetHeaders(file) - attributes(headers)[["status"]] - }, - error = function(e) { - 404 + # Recognize model through file extension + if (is.character(file) && tolower(stringr::str_extract(file, "\\.([^.]+)$")) == ".rds") { + file <- readRDS(file) + } + if (is.character(file)) { + if (is.null(model)) { + model <- switch(stringr::str_extract(file, "\\.([^.]+)$"), + ".sso" = { + cli::cli_alert_info("Processing Stock Synthesis output file...") + "ss3" + }, + ".rdat" = { + cli::cli_alert_info("Processing BAM output file...") + "bam" + }, + # ".rds" = { + # cli::cli_alert_info("Processing WHAM output file...") + # "wham" + # }, + # ".RDS" = { + # cli::cli_alert_info("Processing FIMS output file...") + # "fims" + # }, + cli::cli_abort("Unknown file type. Please indicate model.") + ) } - ) - if (check == 404) cli::cli_abort(c(message = "Invalid URL.")) - } else { - if (!file.exists(file)) { - cli::cli_abort(c( - message = "`file` not found.", - "i" = "`file` entered as {file}" - )) + } else { + model <- switch(class(file)[1], + "fims" = { + cli::cli_alert_info("Processing FIMS output file...") + "fims" + }, + "Rceattle" = { + cli::cli_alert_info("Processing Rceattle output file...") + "rceattle" + }, + "list" = { + if (any(grepl("wham_version", names(file)))) { + cli::cli_alert_info("Processing WHAM output file...") + "wham" + } else { + cli::cli_alert_info("Processing SS3 r4ss output file...") + "ss3" + } + }, + cli::cli_abort("Unknown file type. Please indicate model.") + ) } - } - } - # Recognize model through file extension - if (is.character(file) && tolower(stringr::str_extract(file, "\\.([^.]+)$")) == ".rds") { - file <- readRDS(file) - } - if (is.character(file)) { - if (is.null(model)) { - model <- switch(stringr::str_extract(file, "\\.([^.]+)$"), - ".sso" = { - cli::cli_alert_info("Processing Stock Synthesis output file...") - "ss3" - }, - ".rdat" = { - cli::cli_alert_info("Processing BAM output file...") - "bam" - }, - # ".rds" = { - # cli::cli_alert_info("Processing WHAM output file...") - # "wham" - # }, - # ".RDS" = { - # cli::cli_alert_info("Processing FIMS output file...") - # "fims" - # }, - cli::cli_abort("Unknown file type. Please indicate model.") - ) - } - } else { - model <- switch(class(file)[1], - "fims" = { - cli::cli_alert_info("Processing FIMS output file...") - "fims" - }, - "Rceattle" = { - cli::cli_alert_info("Processing Rceattle output file...") - "rceattle" - }, - "list" = { - if (any(grepl("wham_version", names(file)))) { - cli::cli_alert_info("Processing WHAM output file...") - "wham" + #### SS3 #### + # SS3 groupings: https://docs.google.com/spreadsheets/d/11-k0xOo3Bit1MbJf2ZjmymzsUNCRhgGkVfXV1jNEdbM/edit?gid=0#gid=0 + # Convert SS3 output Report.sso file + if (tolower(model) == "ss3") { + out_new <- conout_ss3(file = file, out_new = out_new, fleet_names = fleet_names[[model_name]]) + } else if (model %in% c("bam", "BAM")) { + #### BAM #### + out_new <- conout_bam(file = file, out_new = out_new, fleet_names = fleet_names[[model_name]]) + #### WHAM ---- + } else if (model == "wham") { + # This is how Bai read the ASAP output + # asap_output conversion written by Bai Li + # asap_output <- dget(file.path(casedir, "output", subdir, paste("s", keep_sim_id[om_sim], sep = ""), "asap3.rdat")) + # setwd(file.path(casedir, "output", subdir, paste("s", keep_sim_id[om_sim], sep = ""))) + # asap_std <- readRep("asap3", suffix = ".std") + cli::cli_abort("WHAM output not currently compatible.") + #### AMAK #### + } else if (model == "amak") { + cli::cli_abort("AMAK output not currently compatible.") + #### JABBA #### + } else if (tolower(model) == "jabba") { + cli::cli_abort("JABBA output not currently compatible.") + #### FIMS #### + } else if (model == "fims") { + if (is.character(file) && length(file) == 1) { + fims_output <- readRDS(file) } else { - cli::cli_alert_info("Processing SS3 r4ss output file...") - "ss3" + fims_output <- file } - }, - cli::cli_abort("Unknown file type. Please indicate model.") - ) - } + # TEMPORARY -- add in era to df + if ("era" %notin% colnames(fims_output)) { + fims_output$era <- NA + } + fims_output[setdiff(tolower(names(out_new)), tolower(names(fims_output)))] <- NA + out_new <- fims_output + #### Rceattle #### + } else if (model == "rceattle") { + out_new <- conout_rceattle(file = file, out_new = out_new, fleet_names = fleet_names[[model_name]]) + } else { + cli::cli_abort(c( + message = "Output file not compatible.", + "i" = "`model` entered as {model}.", + "i" = "Accepted `model` options: ss3, bam, or fims." + )) + } + + # Call in csv for model + con_file <- system.file("resources", glue::glue("{tolower(model)}_var_names.csv"), package = "stockplotr", mustWork = TRUE) + # temporarily add call to local csv so I can test + # con_file <- glue::glue("~/GitHub/stockplotr/inst/resources/{model}_var_names.csv") + var_names_sheet <- utils::read.csv(con_file, na.strings = "") + + if (tolower(model) == "bam") { + var_names_sheet <- var_names_sheet |> + dplyr::mutate(label = tolower(label)) + } + + if (file.exists(con_file)) { + # Remove 'X' column if it exists + var_names_sheet <- var_names_sheet |> + dplyr::select(-dplyr::any_of("X")) + if (tolower(model) == "ss3" & !is.character(file)) { + var_names_sheet <- var_names_sheet |> dplyr::select(-module_name) + out_new <- dplyr::left_join(out_new, var_names_sheet, by = "label") + } else { + var_names_sheet <- var_names_sheet |> + dplyr::distinct(module_name, label, .keep_all = TRUE) + out_new <- dplyr::left_join( + out_new, + var_names_sheet, + by = c("module_name", "label"), + relationship = "many-to-one" + ) + } + out_new <- out_new |> + dplyr::mutate(label = dplyr::case_when( + !is.na(alt_label) ~ alt_label, + # TODO: add this to ss3_var_names.xlsx + label == "dev" & module_name == "SPAWN_RECRUIT" ~ "recruitment_deviation", + # TODO: add this to ss3_var_names.xlsx + label == "dev" & module_name == "SPAWN_RECRUIT_CURVE" ~ "recruitment_deviation", + # TODO: add this to ss3_var_names.xlsx + label == "dev" & module_name == "DISCARD_OUTPUT" ~ "discard_deviation", + TRUE ~ label + )) |> + dplyr::select(-alt_label) |> + dplyr::rename(length_bins = len_bins) + } + + + out_new <- out_new |> dplyr::mutate(model=model_name) + return(tibble::tibble(out_new)) + }) + + out_new <- dplyr::bind_rows(processed) # aggregate all of the models - #### SS3 #### - # SS3 groupings: https://docs.google.com/spreadsheets/d/11-k0xOo3Bit1MbJf2ZjmymzsUNCRhgGkVfXV1jNEdbM/edit?gid=0#gid=0 - # Convert SS3 output Report.sso file - if (tolower(model) == "ss3") { - out_new <- conout_ss3(file = file, out_new = out_new, fleet_names = fleet_names) - } else if (model %in% c("bam", "BAM")) { - #### BAM #### - out_new <- conout_bam(file = file, out_new = out_new, fleet_names = fleet_names) - #### WHAM ---- - } else if (model == "wham") { - # This is how Bai read the ASAP output - # asap_output conversion written by Bai Li - # asap_output <- dget(file.path(casedir, "output", subdir, paste("s", keep_sim_id[om_sim], sep = ""), "asap3.rdat")) - # setwd(file.path(casedir, "output", subdir, paste("s", keep_sim_id[om_sim], sep = ""))) - # asap_std <- readRep("asap3", suffix = ".std") - cli::cli_abort("WHAM output not currently compatible.") - #### AMAK #### - } else if (model == "amak") { - cli::cli_abort("AMAK output not currently compatible.") - #### JABBA #### - } else if (tolower(model) == "jabba") { - cli::cli_abort("JABBA output not currently compatible.") - #### FIMS #### - } else if (model == "fims") { - if (is.character(file) && length(file) == 1) { - fims_output <- readRDS(file) - } else { - fims_output <- file - } - # TEMPORARY -- add in era to df - if ("era" %notin% colnames(fims_output)) { - fims_output$era <- NA - } - fims_output[setdiff(tolower(names(out_new)), tolower(names(fims_output)))] <- NA - out_new <- fims_output - #### Rceattle #### - } else if (model == "rceattle") { - out_new <- conout_rceattle(file = file, out_new = out_new, fleet_names = fleet_names) - } else { - cli::cli_abort(c( - message = "Output file not compatible.", - "i" = "`model` entered as {model}.", - "i" = "Accepted `model` options: ss3, bam, or fims." - )) - } #### Exporting #### # Combine DFs into one @@ -264,48 +317,6 @@ convert_output <- function( ) |> suppressWarnings() - # Call in csv for model - con_file <- system.file("resources", glue::glue("{tolower(model)}_var_names.csv"), package = "stockplotr", mustWork = TRUE) - # temporarily add call to local csv so I can test - # con_file <- glue::glue("~/GitHub/stockplotr/inst/resources/{model}_var_names.csv") - var_names_sheet <- utils::read.csv(con_file, na.strings = "") - - if (tolower(model) == "bam") { - var_names_sheet <- var_names_sheet |> - dplyr::mutate(label = tolower(label)) - } - - if (file.exists(con_file)) { - # Remove 'X' column if it exists - var_names_sheet <- var_names_sheet |> - dplyr::select(-dplyr::any_of("X")) - if (tolower(model) == "ss3" & !is.character(file)) { - var_names_sheet <- var_names_sheet |> dplyr::select(-module_name) - out_new <- dplyr::left_join(out_new, var_names_sheet, by = "label") - } else { - var_names_sheet <- var_names_sheet |> - dplyr::distinct(module_name, label, .keep_all = TRUE) - out_new <- dplyr::left_join( - out_new, - var_names_sheet, - by = c("module_name", "label"), - relationship = "many-to-one" - ) - } - out_new <- out_new |> - dplyr::mutate(label = dplyr::case_when( - !is.na(alt_label) ~ alt_label, - # TODO: add this to ss3_var_names.xlsx - label == "dev" & module_name == "SPAWN_RECRUIT" ~ "recruitment_deviation", - # TODO: add this to ss3_var_names.xlsx - label == "dev" & module_name == "SPAWN_RECRUIT_CURVE" ~ "recruitment_deviation", - # TODO: add this to ss3_var_names.xlsx - label == "dev" & module_name == "DISCARD_OUTPUT" ~ "discard_deviation", - TRUE ~ label - )) |> - dplyr::select(-alt_label) |> - dplyr::rename(length_bins = len_bins) - } cli::cli_alert_success("Conversion finished!") # save if indicated @@ -319,5 +330,6 @@ convert_output <- function( # assign(save_name, out_new) save(out_new, file = save_dir) } - tibble::as_tibble(out_new) + + return(out_new) } # close function From 6821495b6404a68790650be91b2e6ec5b5ef5406 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Wed, 4 Nov 2026 16:21:00 -0500 Subject: [PATCH 02/17] fix: :bug: make sure input is a list of models --- R/convert_output.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/convert_output.R b/R/convert_output.R index d09c3e79..56057590 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -49,6 +49,12 @@ convert_output <- function( save_dir = NULL ) { + if(any(grepl("Data_File|data_list", names(files)))){ + cli::cli_alert("`files` appears to represent a single model. Converting to list object.") + files <- list(files) + } + + processed <- purrr::imap(files, function(file, model_name){ if (is.character(file) && grepl("Report.sso", file)) { lifecycle::deprecate_warn( From 0a45764cf1c0f4fe1857d6a08224c0e1dc64bac9 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Wed, 4 Nov 2026 16:21:28 -0500 Subject: [PATCH 03/17] fix: make sure columns are same type across model platforms --- R/convert_output.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/R/convert_output.R b/R/convert_output.R index 56057590..4a576525 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -48,8 +48,9 @@ convert_output <- function( fleet_names = NULL, save_dir = NULL ) { - - if(any(grepl("Data_File|data_list", names(files)))){ + + # Is user inputs a single model file and doesn't wrap it as a list object + if(any(grepl("Data_File|data_list", names(files))) || is.character(files)){ cli::cli_alert("`files` appears to represent a single model. Converting to list object.") files <- list(files) } @@ -284,7 +285,13 @@ convert_output <- function( } - out_new <- out_new |> dplyr::mutate(model=model_name) + out_new <- out_new |> + dplyr::mutate( + model=model_name, + year=as.character(year), + month=as.character(month), + block=as.character(block) + ) return(tibble::tibble(out_new)) }) From ae061be1950b197698b6190c344cdba1183a58f4 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Wed, 4 Nov 2026 16:52:35 -0500 Subject: [PATCH 04/17] tests: update expected dimensions not that "model" column is always appended to converted outputs --- tests/testthat/test-convert_output.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-convert_output.R b/tests/testthat/test-convert_output.R index 12b477a8..f44253f7 100644 --- a/tests/testthat/test-convert_output.R +++ b/tests/testthat/test-convert_output.R @@ -24,7 +24,7 @@ test_that("convert_output works for SS3", { )) # Check that the result has exactly 35 columns - expect_equal(dim(result)[2], 35) + expect_equal(dim(result)[2], 36) } # Test saving the output in a global environment @@ -32,7 +32,7 @@ test_that("convert_output works for SS3", { file = file.path(all_models[1], "Report.sso") ) - expect_equal(dim(output)[2], 35) + expect_equal(dim(output)[2], 36) }) test_that("convert_output does not emit scalar case_when deprecation warning", { @@ -92,14 +92,14 @@ test_that("r4ss::ss_output object is compatible.", { simple_r4ss <- readRDS(fs::path("fixtures", "r4ss_output", "simple_small", "simple_r4ss.rds")) expect_no_error(result <- convert_output(simple_r4ss)) - expect_equal(dim(result)[2], 35) + expect_equal(dim(result)[2], 36) }) test_that("URL input is compatible", { expect_no_error(result <- convert_output( - file = "https://raw.githubusercontent.com/pfmc-assessments/petrale/main/models/2023.a050.003_FIMS_case-study_wtatage/Report.sso" + files = "https://raw.githubusercontent.com/pfmc-assessments/petrale/main/models/2023.a050.003_FIMS_case-study_wtatage/Report.sso" )) - expect_equal(dim(result)[2], 35) + expect_equal(dim(result)[2], 36) }) test_that("invalid URL input triggers an error", { @@ -153,7 +153,7 @@ test_that("convert_output works for Rceattle", { model = "rceattle" )) - expect_equal(dim(from_path)[2], 35) + expect_equal(dim(from_path)[2], 36) expect_equal(from_path, from_object) # Every row says which module it came from. From 9ede8eb8ae0094fbfb375c69a1e6d27245365840 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Wed, 4 Nov 2026 16:53:31 -0500 Subject: [PATCH 05/17] tests: add test for convert_output on multiple models. Test against two SS3 models and a combination of SS3 and Rceattle models. --- tests/testthat/test-convert_output.R | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/tests/testthat/test-convert_output.R b/tests/testthat/test-convert_output.R index f44253f7..c462ee3f 100644 --- a/tests/testthat/test-convert_output.R +++ b/tests/testthat/test-convert_output.R @@ -308,3 +308,29 @@ test_that("convert_output refuses a multispecies Rceattle fit", { "Rceattle model has 3 species" ) }) + +test_that("convert_output on multiple SS3 models", { + model_files <- list( + "hake2018"=fs::path("fixtures", "ss3_models", "models", "Hake_2018"), + "BigSkate2019"=fs::path("fixtures", "ss3_models", "models", "BigSkate_2019") + ) + + models_r4ss <- lapply(model_files, \(x) r4ss::SS_output(x)) + + expect_no_error(result <- convert_output(models_r4ss)) + expect_equal(dim(result)[2], 36) + expect_equal(result$model %>% unique, c("hake2018", "BigSkate2019")) +}) + +test_that("convert_output on SS3 and Rceattle model", { + + ss3_hake2018 <- r4ss::SS_output(fs::path("fixtures", "ss3_models", "models", "Hake_2018")) + rceattle_atf <- readRDS(fs::path("fixtures", "rceattle_goa_atf.rds")) + + models <- list("ss3_hake"=ss3_hake2018, "rceattle_atf"=rceattle_atf) + + expect_no_error(result <- convert_output(models)) + expect_equal(dim(result)[2], 36) + expect_equal(result$model %>% unique, c("ss3_hake", "rceattle_atf")) +}) + From b3f7f968a046b9558f0534c192128e926151a4cb Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Thu, 5 Nov 2026 11:21:10 -0500 Subject: [PATCH 06/17] refactor: removed list processing from filter_data Multimodel data processing is now handled natively by `convert_output` --- R/utils_plot.R | 152 +++++++++++++++++++++---------------------------- 1 file changed, 65 insertions(+), 87 deletions(-) diff --git a/R/utils_plot.R b/R/utils_plot.R index 691b52fd..5534e191 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -699,84 +699,56 @@ filter_data <- function( # TODO: add option to scale data # Replace all spaces with underscore if not in proper format label_name <- gsub(" ", "_", tolower(label_name)) - list_of_data <- list() - length_dat <- ifelse( - is.data.frame(dat), - 1, - length(dat) - ) - for (i in 1:length_dat) { - # start for loop to bring together each data as their own geom - # Add columns to data if grouping is selected - # format geoms the way we want - # ggplot easier and more consistent to use - # defaults are focused for stock assessment - # vignette to show how you can filter the data instead of the devs - # vignette is the effort to show what to do and has example - # would have to use the plus operator - - if (is.data.frame(dat)) { - data <- dat - model_label <- FALSE + + model_label <- any(grepl("model", colnames(dat))) + if(!model_label){ + dat <- dat |> dplyr::mutate(model="1") + } + + plot_data <- dat |> + # make sure all labels are lowercase and spaces are replaced with underscores + dplyr::mutate( + label = tolower(gsub(" ", "_", label)) + ) |> + dplyr::filter( + grepl(glue::glue("{label_name}"), label) + # era == era + ) |> + dplyr::mutate( + year = as.numeric(year), + # calc uncertainty when se + # TODO: calculate other sources of error to upper and lower (cv,) + estimate_lower = dplyr::case_when( + grepl("se", uncertainty_label) ~ estimate - ((1.96 * uncertainty)) / scale_amount, + grepl("sd", tolower(uncertainty_label)) | grepl("std", tolower(uncertainty_label)) ~ (estimate - uncertainty) / scale_amount, + grepl("cv", tolower(uncertainty_label)) ~ (estimate - (1.96 * (uncertainty * estimate))) / scale_amount, + TRUE ~ NA + ), + estimate_upper = dplyr::case_when( + grepl("se", uncertainty_label) ~ (estimate + (1.96 * uncertainty)) / scale_amount, + grepl("sd", tolower(uncertainty_label)) | grepl("std", tolower(uncertainty_label)) ~ (estimate + uncertainty) / scale_amount, + grepl("cv", tolower(uncertainty_label)) ~ (estimate + (1.96 * (uncertainty * estimate))) / scale_amount, + TRUE ~ NA + ), + estimate = as.numeric(estimate) / scale_amount + ) + # must rename era arg bc dplyr gets confused + era_selection <- era + if (!is.null(era)) { + plot_data <- dplyr::filter( + plot_data, + grepl(era_selection, era) + ) + } + if (nrow(plot_data) < 1) cli::cli_abort("{label_name} not found.") + if (is.null(group)) { + if (!is.data.frame(dat) || (plot_data %>% dplyr::distinct(model) %>% nrow) > 1) { + plot_data <- plot_data |> + dplyr::mutate( + group_var = as.character(.data[["model"]]) + ) } else { - data <- dat[[i]] - model_label <- TRUE - } - data <- data |> - # make sure all labels are lowercase and spaces are replaced with underscores - dplyr::mutate( - label = tolower(gsub(" ", "_", label)) - ) |> - dplyr::filter( - grepl(glue::glue("{label_name}"), label) - # era == era - ) |> - dplyr::mutate( - year = as.numeric(year), - model = ifelse(model_label, get_id(dat)[i], "1"), # NA -- changed from NA to 1 for processing reasons, might need to change back if issue - # calc uncertainty when se - # TODO: calculate other sources of error to upper and lower (cv,) - estimate_lower = dplyr::case_when( - grepl("se", uncertainty_label) ~ estimate - ((1.96 * uncertainty)) / scale_amount, - grepl("sd", tolower(uncertainty_label)) | grepl("std", tolower(uncertainty_label)) ~ (estimate - uncertainty) / scale_amount, - grepl("cv", tolower(uncertainty_label)) ~ (estimate - (1.96 * (uncertainty * estimate))) / scale_amount, - TRUE ~ NA - ), - estimate_upper = dplyr::case_when( - grepl("se", uncertainty_label) ~ (estimate + (1.96 * uncertainty)) / scale_amount, - grepl("sd", tolower(uncertainty_label)) | grepl("std", tolower(uncertainty_label)) ~ (estimate + uncertainty) / scale_amount, - grepl("cv", tolower(uncertainty_label)) ~ (estimate + (1.96 * (uncertainty * estimate))) / scale_amount, - TRUE ~ NA - ), - estimate = as.numeric(estimate) / scale_amount - ) - # must rename era arg bc dplyr gets confused - era_selection <- era - if (!is.null(era)) { - data <- dplyr::filter( - data, - grepl(era_selection, era) - ) - } - if (nrow(data) < 1) cli::cli_abort("{label_name} not found.") - if (is.null(group)) { - if (!is.data.frame(dat)) { - data <- data |> - dplyr::mutate( - group_var = as.character(.data[["model"]]) - ) - } else { - data <- data |> - dplyr::mutate( - group_var = switch(geom, - "line" = "solid", - "point" = "black", - 1 - ) - ) - } - } else if (all(is.na(data[[group]]))) { - data <- data |> + plot_data <- plot_data |> dplyr::mutate( group_var = switch(geom, "line" = "solid", @@ -784,18 +756,24 @@ filter_data <- function( 1 ) ) - # Set group to NULL if second condition is met - group <- NULL - } else { - data <- data |> - dplyr::mutate( - group_var = .data[[group]] - ) } - list_of_data[[ifelse(model_label, get_id(dat)[i], "1")]] <- data + } else if (all(is.na(plot_data[[group]]))) { + plot_data <- plot_data |> + dplyr::mutate( + group_var = switch(geom, + "line" = "solid", + "point" = "black", + 1 + ) + ) + # Set group to NULL if second condition is met + group <- NULL + } else { + plot_data <- plot_data |> + dplyr::mutate( + group_var = .data[[group]] + ) } - # Put in - plot_data <- dplyr::bind_rows(list_of_data, .id = "model") # Check if there are multiple module_names present if (length(unique(plot_data$module_name)) > 1) { From fa2277e8cfcdfbc3f232667819bb6f2d9a57f353 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Thu, 5 Nov 2026 11:22:06 -0500 Subject: [PATCH 07/17] test: add tests for multimodel data processing Verify that `filter_data` works on two models and that ` plot_spawning_biomass` generates a plot with two lines. --- tests/testthat/test-plot_spawning_biomass.R | 14 ++++++++++++++ tests/testthat/test-utils_plot.R | 21 +++++++++++++++++++-- 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-plot_spawning_biomass.R b/tests/testthat/test-plot_spawning_biomass.R index dea24c82..f12c97c6 100644 --- a/tests/testthat/test-plot_spawning_biomass.R +++ b/tests/testthat/test-plot_spawning_biomass.R @@ -56,3 +56,17 @@ test_that("plot_spawning_biomass generates plots without errors", { # # expect that both figures dir and the spawning_biomass_figure.rda file exist # check_and_remove_tmp_files("spawning_biomass_figure.rda") # }) + +test_that("plot_spawning_biomass generates plots for multiple models", { + dat <- convert_output(list( + "model1" = r4ss::SS_output(test_path("fixtures", "ss3_models", "models", "platoons")), + "model2" = r4ss::SS_output(test_path("fixtures", "ss3_models", "models", "Empirical_Wtatage_Age_Selex")) + )) + + expect_no_error(plt <- plot_spawning_biomass(dat, module="derived_quants")) + expect_s3_class(plt, "gg") + + p <- ggplot2::ggplot_build(plt) + expect_equal(length(unique(p$data[[1]]$group)), 2) + +}) diff --git a/tests/testthat/test-utils_plot.R b/tests/testthat/test-utils_plot.R index 7ac228cb..f66687b8 100644 --- a/tests/testthat/test-utils_plot.R +++ b/tests/testthat/test-utils_plot.R @@ -28,8 +28,25 @@ make_utils_plot_multimodule_data <- function() { ) } -test_that("filter_data handles data frames and lists", { +make_utils_plot_multimodel_data <- function() { + tibble::tibble( + label = c("biomass", "biomass", "biomass", "biomass_msy", "biomass_unfished"), + estimate = c(100, 120, 140, 110, 200), + module_name = c("TIME_SERIES", "TIME_SERIES", "TIME_SERIES", "TIME_SERIES", "TIME_SERIES"), + year = c(2000, 2001, 2002, NA, NA), + fleet = c("fleet_a", "fleet_a", "fleet_b", NA, NA), + age = c(1, 2, 3, NA, NA), + season = c("spring", "spring", "fall", NA, NA), + uncertainty = c(10, 10, 10, NA, NA), + uncertainty_label = c("se", "se", "se", NA, NA), + era = c("time", "time", "time", "time", "time"), + model = c("model_one", "model_one", "model_two", "model_two", "model_two") + ) +} + +test_that("filter_data handles data frames", { dat <- make_utils_plot_data() + mm_dat <- make_utils_plot_multimodel_data() filtered <- filter_data( dat = dat, @@ -42,7 +59,7 @@ test_that("filter_data handles data frames and lists", { expect_equal(unique(filtered$model), "1") filtered_list <- filter_data( - dat = list(model_one = dat, model_two = dat), + dat = mm_dat, label_name = "biomass", geom = "point", interactive = FALSE From af39895368d23b4f273aa891914a823d7525c58f Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Thu, 5 Nov 2026 12:13:52 -0500 Subject: [PATCH 08/17] refactor: remove dplyr deprecation warnings from conout_ss3 --- R/conout_ss3.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/conout_ss3.R b/R/conout_ss3.R index 0eb02cc6..1200dc0a 100644 --- a/R/conout_ss3.R +++ b/R/conout_ss3.R @@ -279,7 +279,7 @@ conout_ss3 <- function( for (i in intersect(tolower(fleet_names), colnames(df3))) { col_name <- glue::glue("exploitation_{i}") df3 <- df3 |> - dplyr::rename(!!col_name := i) + dplyr::rename(!!col_name := dplyr::all_of(i)) } } } @@ -326,7 +326,7 @@ conout_ss3 <- function( if (length(err_col_id) > 0) { uncert_name <- stringr::str_extract(err_col_id, paste0(errors, collapse = "|")) df3 <- df3 |> - dplyr::rename(!!uncert_name := err_col_id) + dplyr::rename(!!uncert_name := dplyr::all_of(err_col_id)) } df4 <- df3 |> tidyr::pivot_longer( From 27178ccdad3376b51613d1e6ff6515b1a211f33c Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Fri, 6 Nov 2026 11:06:07 -0500 Subject: [PATCH 09/17] test: add test for plot_abundance_at_age with multiple models --- tests/testthat/test-plot_abundance_at_age.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/testthat/test-plot_abundance_at_age.R b/tests/testthat/test-plot_abundance_at_age.R index 64381c1e..853f6563 100644 --- a/tests/testthat/test-plot_abundance_at_age.R +++ b/tests/testthat/test-plot_abundance_at_age.R @@ -164,3 +164,17 @@ test_that("plot contains a legend", { ) expect_true(!is.null(plot$theme$legend.position)) }) + +test_that("plot_abundace_at_age generates plots for multiple models", { + dat <- convert_output(list( + "model1" = r4ss::SS_output(test_path("fixtures", "ss3_models", "models", "Hake_2018")), + "model2" = r4ss::SS_output(test_path("fixtures", "ss3_models", "models", "Hake_2019_semi-parametric_selex")) + )) + + expect_no_error(plt <- plot_abundance_at_age(dat, module="natage")) + expect_s3_class(plt, "gg") + + p <- ggplot2::ggplot_build(plt) + expect_equal(length(unique(p$data[[1]]$PANEL)), 4) + +}) From 7d89219b0231f374e2835dd4e27e9ec5e97ac905 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Fri, 6 Nov 2026 14:31:09 -0500 Subject: [PATCH 10/17] refactor: change reference_line helper functions to work with multiple models --- R/utils_plot.R | 41 ++++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/R/utils_plot.R b/R/utils_plot.R index 5534e191..9991a703 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -870,7 +870,8 @@ calculate_reference_point <- function( # Remove values with year - want single point dat <- dat |> dplyr::mutate(label = tolower(label)) |> - dplyr::filter(is.na(year)) + dplyr::filter(is.na(year)) |> + dplyr::distinct() reference_rows <- grep( pattern = glue::glue("^{reference_name}$"), x = dat[["label"]] @@ -1156,20 +1157,31 @@ add_reference_line <- function( # 2. custom input vector = c("sable23_msy"=30, "sable25_msy"=40) -- user must indicate which model in label otherwise it will assign in order of dat # 3. input vector of labels = c("msy", "target") # getting data set - an ifelse statement in the fxn wasn't working + if("model" %in% colnames(dat)){ + model_names <- dat |> dplyr::distinct(model) |> dplyr::pull(model) + n_models <- length(model_names) + }else{ + n_models <- 1 + } + ref_lines_list <- list() if (!is.null(ref_line)) { # Check if length of ref_line = dat -- replicate value if not - if (!is.data.frame(dat) & length(ref_line) != length(dat)) ref_line <- rep(ref_line, length(dat)) + # Need to check this + # if (!is.data.frame(dat) & length(ref_line) != length(dat)) ref_line <- rep(ref_line, length(dat)) + + if(n_models > 1 & length(ref_line)==1) ref_line <- rep(ref_line, n_models) + # Put into for loop and add lines sequentially to plt for (i in 1:length(ref_line)) { # find the reference point value if (is.null(names(ref_line[i]))) { ref_line_x <- calculate_reference_point( - dat = if (is.data.frame(dat)) { - dat - } else { - dat[[i]] - }, + dat = if(n_models == 1){ + dat + } else { + dat %>% dplyr::filter(model == model_names[i]) + }, reference_name = glue::glue("{label}_{ref_line[i]}"), lbs = lbs ) / scale_amount @@ -1183,11 +1195,7 @@ add_reference_line <- function( } if ("unfished" %in% names(ref_line_x)) { - if (is.data.frame(dat)) { - sel_dat <- dat - } else { - sel_dat <- dat[[i]] - } + sel_dat <- dat %>% dplyr::filter(model == model_names[i]) plt_lab <- label # find the minimum x axis value from the plot min_year <- sel_dat |> @@ -1200,7 +1208,10 @@ add_reference_line <- function( # TODO: set color for each point to match that of the line for the model ref_lines_list <- append( ref_lines_list, - ggplot2::geom_point(ggplot2::aes(x = min_year - 1, y = ref_line_x, color = model)) # should I keep -1 or set as first year? + ggplot2::geom_point( + data = sel_dat, + ggplot2::aes(x = min_year - 1, y = ref_line_x, color = model) + ) # should I keep -1 or set as first year? ) } else { # add apply/purrr/or for loop for reference lines -- not just the first anymore @@ -1209,10 +1220,10 @@ add_reference_line <- function( ref_lines_list, reference_line( # conditionally add label name - label_name = ifelse(length(names(dat)[i]) == 1, label, names(dat)[i]), # "spawning_biomass", + label_name = ifelse(n_models == 1, label, model_names[i]), # "spawning_biomass", ref_line = ref_line_x, scale_amount = scale_amount, - model_name = ifelse(is.data.frame(dat), "1", names(dat)[i]), + model_name = ifelse(n_models == 1, "1", model_names[i]), direction = plot_direction ) ) From fd4e0cb574fe805f3f531bd6124b8c86f1bc8f61 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Fri, 6 Nov 2026 14:31:47 -0500 Subject: [PATCH 11/17] tests: add tests for multiple reference lines --- tests/testthat/test-utils_plot.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/testthat/test-utils_plot.R b/tests/testthat/test-utils_plot.R index f66687b8..5e633c51 100644 --- a/tests/testthat/test-utils_plot.R +++ b/tests/testthat/test-utils_plot.R @@ -180,6 +180,25 @@ test_that("reference and scalar utility helpers behave as expected", { } expect_true(has_hline(ref_plot)) + mm_dat <- make_utils_plot_multimodel_data() + mm_dat <- mm_dat |> dplyr::add_row( + label = "biomass_msy", + estimate = 120, module_name="TIME_SERIES", + year=NA, fleet=NA, age=NA, season=NA, uncertainty=NA, uncertainty_label=NA, + era="time", model="model_one" + ) + ts_dat <- filter_data( + dat = mm_dat, + label_name = "biomass", + geom = "line", + interactive = FALSE + ) + base_plot <- plot_timeseries(ts_dat, geom = "line") + + ref_plot <- base_plot + add_reference_line(mm_dat, ref_line="msy", label="biomass") + expect_true(has_hline(ref_plot)) # make sure it has A line + expect_equal(sum(sapply(ref_plot$layers, function(layer) inherits(layer$geom, "GeomHline"))), 2) # make sure it has TWO lines + # missing_ref_plot <- base_plot + reference_line( # label_name = "biomass", # ref_line = 50 From 636e749c3502d94a69976133d0315e5055955efd Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Fri, 6 Nov 2026 14:32:14 -0500 Subject: [PATCH 12/17] tests: use custom directories for wiring RDA files for export-rda tests --- tests/testthat/test-export_rda.R | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-export_rda.R b/tests/testthat/test-export_rda.R index 8f2481dc..808c5f8b 100644 --- a/tests/testthat/test-export_rda.R +++ b/tests/testthat/test-export_rda.R @@ -5,14 +5,16 @@ test_that("export_rda works for figures", { B.min <- 100 B.max <- 200 + custom_dir <- fs::path(getwd(), "tests-export_rda") + # add KQs to caps/alt text csv - insert_kqs(B.min, B.max) + insert_kqs(B.min, B.max, dir=custom_dir) # extract this plot's caption and alt text caps_alttext <- extract_caps_alttext( topic_label = topic_label, fig_or_table = fig_or_table, - dir = getwd() + dir = custom_dir ) # make a simple plot @@ -24,21 +26,21 @@ test_that("export_rda works for figures", { export_rda( object = final, caps_alttext = caps_alttext, - figures_tables_dir = getwd(), + figures_tables_dir = custom_dir, topic_label = topic_label, fig_or_table = fig_or_table ) # expect that both figures dir and the biomass_figure.rda file exist - expect_true(dir.exists(fs::path(getwd(), "figures"))) + expect_true(dir.exists(fs::path(custom_dir, "figures"))) expect_true(file.exists(fs::path( - getwd(), "figures", "biomass_figure.rda" + custom_dir, "figures", "biomass_figure.rda" ))) # erase temporary testing files - file.remove(fs::path(getwd(), "captions_alt_text.csv")) + file.remove(fs::path(custom_dir, "captions_alt_text.csv")) # file.remove(fs::path(getwd(), "key_quantities.csv")) # file is not made in this test - unlink(fs::path(getwd(), "figures"), recursive = T) + unlink(fs::path(custom_dir, "figures"), recursive = T) }) test_that("export_rda works for tables", { @@ -48,14 +50,16 @@ test_that("export_rda works for tables", { B.min <- 100 B.max <- 200 + custom_dir <- fs::path(getwd(), "tests-export_rda") + # add KQs to caps/alt text csv - insert_kqs(B.min, B.max) + insert_kqs(B.min, B.max, dir=custom_dir) # extract this plot's caption and alt text caps_alttext <- extract_caps_alttext( topic_label = topic_label, fig_or_table = fig_or_table, - dir = getwd() + dir = custom_dir ) # make a simple table @@ -68,19 +72,19 @@ test_that("export_rda works for tables", { export_rda( object = final, caps_alttext = caps_alttext, - figures_tables_dir = getwd(), + figures_tables_dir = custom_dir, topic_label = topic_label, fig_or_table = fig_or_table ) # expect that both tables dir and the biomass_abundance_catch_table.rda file exist - expect_true(dir.exists(fs::path(getwd(), "tables"))) - expect_true(file.exists(fs::path(getwd(), "tables", "biomass_abundance_catch_table.rda"))) + expect_true(dir.exists(fs::path(custom_dir, "tables"))) + expect_true(file.exists(fs::path(custom_dir, "tables", "biomass_abundance_catch_table.rda"))) # erase temporary testing files - file.remove(fs::path(getwd(), "captions_alt_text.csv")) + file.remove(fs::path(custom_dir, "captions_alt_text.csv")) # file.remove(fs::path(getwd(), "key_quantities.csv")) # file is not made in this test ? - unlink(fs::path(getwd(), "tables"), recursive = T) + unlink(fs::path(custom_dir, "tables"), recursive = T) }) From e1d6d0d7dca6f0f31e2572b56fefa7097fb83f82 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Mon, 9 Nov 2026 10:16:17 -0500 Subject: [PATCH 13/17] feat: Add handling for specifying "models" and "fleet_names" parameters alongside multiple models --- R/convert_output.R | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/R/convert_output.R b/R/convert_output.R index 4a576525..b1347fbb 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -55,8 +55,22 @@ convert_output <- function( files <- list(files) } + if(!all(is.null(models)) & length(models) != length(files)){ + cli::cli_alert_warning("Number of model types entered is different from number of models.") + models <- c(models, rep(NA, length(files)-length(models))) # can't store NULL in vector so make a string + cli::cli_alert(glue::glue("Model types are: {paste0(\"'\",models,\"'\", collapse=\",\")}")) + } + + if(length(fleet_names) != length(files)){ + cli::cli_alert_warning("Number of fleet_names enetered is different from number of models.") + fleet_names <- c(fleet_names, rep(list(NULL), length(files)-length(fleet_names))) + names(fleet_names) <- names(files) + cli::cli_alert(glue::glue("Fleets names are: {str(fleet_names)}")) + } + processed <- purrr::imap(files, function(file, model_name){ + i <- which(names(files)==model_name) if (is.character(file) && grepl("Report.sso", file)) { lifecycle::deprecate_warn( when = "2.8.0", @@ -151,7 +165,7 @@ convert_output <- function( file <- readRDS(file) } if (is.character(file)) { - if (is.null(model)) { + if (is.null(models) || is.na(models[i])) { model <- switch(stringr::str_extract(file, "\\.([^.]+)$"), ".sso" = { cli::cli_alert_info("Processing Stock Synthesis output file...") From 719a1119dd436abe9c6f9fd1cecbbbe6fedd6638 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Mon, 9 Nov 2026 10:21:55 -0500 Subject: [PATCH 14/17] docs: Update roxygen to reflect changes to parameters for multiple model handling --- R/convert_output.R | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/R/convert_output.R b/R/convert_output.R index b1347fbb..c16272a8 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -2,19 +2,30 @@ #' #' Format stock assessment output file to a standardized tibble. #' -#' @param file Path. Assessment model output file path. Currently accepts SS3 -#' `r4ss::ss_output()` or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, and FIMS model object. -#' @param model String. Assessment model used in evaluation +#' @param files List of Paths. Assessment model output file paths. Currently accepts SS3 +#' `r4ss::ss_output()` or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, +#' and FIMS model object. If multiple elements, all valid models will be read, converted, and +#' appended together. +#' +#' `names(files)` will be used as the name of the model in the output. +#' +#' @param models Character vector Assessment model used in evaluation #' #' Default: NULL #' #' Options: "ss3", "bam", "fims", "rceattle" -#' @param fleet_names Character vector. Names of fleets in the assessment model as +#' +#' Should match length of `files`. +#' +#' @param fleet_names List of Character vector. Names of fleets in the assessment model as #' shortened in the output file or names of fleets to replace the native fleet #' names in the output. For example, if fleet names in the model are 1, 2, 3 #' then fleet_names = c("fleet1" = 1, "fleet2" = 2, "fleet3" = 3). #' #' Default: NULL +#' +#' Should match length of `files`. +#' #' @param save_dir Path. Full file path to save the converted output file. If #' saved file name is not indicated, the file will be saved as "std_output.rda" #' in the file path provided. @@ -41,6 +52,12 @@ #' fleet_names = c("TWL", "NONTWL"), #' save_dir = here::here("standard_output.rda") #' ) +#' convert_output( +#' file = list("model1"=here::here("model1", "Report.sso", "model2"=here::here("model2", "Report.sso")), +#' model = c("ss3", "ss3"), +#' fleet_names = list("model1"=c("TWL", "NONTWL"), "model2"=c("Fishery1", "Survey1", "Survey2")), +#' save_dir = here::here("standard_output.rda") +#' ) #' } convert_output <- function( files, From c0f24d30976e25cf1c8b3ffb60e4297a7939504b Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Mon, 9 Nov 2026 10:21:55 -0500 Subject: [PATCH 15/17] docs: Update roxygen to reflect changes to parameters for multiple model handling --- R/convert_output.R | 25 +++++++++++++++++++++---- man/conout_bam.Rd | 9 ++++----- man/conout_rceattle.Rd | 9 ++++----- man/conout_ss3.Rd | 9 ++++----- man/convert_output.Rd | 28 +++++++++++++++++++++------- 5 files changed, 54 insertions(+), 26 deletions(-) diff --git a/R/convert_output.R b/R/convert_output.R index b1347fbb..c16272a8 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -2,19 +2,30 @@ #' #' Format stock assessment output file to a standardized tibble. #' -#' @param file Path. Assessment model output file path. Currently accepts SS3 -#' `r4ss::ss_output()` or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, and FIMS model object. -#' @param model String. Assessment model used in evaluation +#' @param files List of Paths. Assessment model output file paths. Currently accepts SS3 +#' `r4ss::ss_output()` or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, +#' and FIMS model object. If multiple elements, all valid models will be read, converted, and +#' appended together. +#' +#' `names(files)` will be used as the name of the model in the output. +#' +#' @param models Character vector Assessment model used in evaluation #' #' Default: NULL #' #' Options: "ss3", "bam", "fims", "rceattle" -#' @param fleet_names Character vector. Names of fleets in the assessment model as +#' +#' Should match length of `files`. +#' +#' @param fleet_names List of Character vector. Names of fleets in the assessment model as #' shortened in the output file or names of fleets to replace the native fleet #' names in the output. For example, if fleet names in the model are 1, 2, 3 #' then fleet_names = c("fleet1" = 1, "fleet2" = 2, "fleet3" = 3). #' #' Default: NULL +#' +#' Should match length of `files`. +#' #' @param save_dir Path. Full file path to save the converted output file. If #' saved file name is not indicated, the file will be saved as "std_output.rda" #' in the file path provided. @@ -41,6 +52,12 @@ #' fleet_names = c("TWL", "NONTWL"), #' save_dir = here::here("standard_output.rda") #' ) +#' convert_output( +#' file = list("model1"=here::here("model1", "Report.sso", "model2"=here::here("model2", "Report.sso")), +#' model = c("ss3", "ss3"), +#' fleet_names = list("model1"=c("TWL", "NONTWL"), "model2"=c("Fishery1", "Survey1", "Survey2")), +#' save_dir = here::here("standard_output.rda") +#' ) #' } convert_output <- function( files, diff --git a/man/conout_bam.Rd b/man/conout_bam.Rd index 7b3ee972..50646cb1 100644 --- a/man/conout_bam.Rd +++ b/man/conout_bam.Rd @@ -7,15 +7,14 @@ conout_bam(file, out_new, fleet_names = NULL) } \arguments{ -\item{file}{Path. Assessment model output file path. Currently accepts SS3 -\code{r4ss::ss_output()} or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, and FIMS model object.} - -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vector. Names of fleets in the assessment model as shortened in the output file or names of fleets to replace the native fleet names in the output. For example, if fleet names in the model are 1, 2, 3 then fleet_names = c("fleet1" = 1, "fleet2" = 2, "fleet3" = 3). -Default: NULL} +Default: NULL + +Should match length of \code{files}.} } \value{ Reshaped data frame. diff --git a/man/conout_rceattle.Rd b/man/conout_rceattle.Rd index 85612b51..9593f6df 100644 --- a/man/conout_rceattle.Rd +++ b/man/conout_rceattle.Rd @@ -7,15 +7,14 @@ conout_rceattle(file, out_new, fleet_names = NULL) } \arguments{ -\item{file}{Path. Assessment model output file path. Currently accepts SS3 -\code{r4ss::ss_output()} or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, and FIMS model object.} - -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vector. Names of fleets in the assessment model as shortened in the output file or names of fleets to replace the native fleet names in the output. For example, if fleet names in the model are 1, 2, 3 then fleet_names = c("fleet1" = 1, "fleet2" = 2, "fleet3" = 3). -Default: NULL} +Default: NULL + +Should match length of \code{files}.} } \value{ Reshaped data frame. diff --git a/man/conout_ss3.Rd b/man/conout_ss3.Rd index fe5de1e8..6d80f6fa 100644 --- a/man/conout_ss3.Rd +++ b/man/conout_ss3.Rd @@ -7,15 +7,14 @@ conout_ss3(file, out_new, fleet_names = NULL) } \arguments{ -\item{file}{Path. Assessment model output file path. Currently accepts SS3 -\code{r4ss::ss_output()} or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, and FIMS model object.} - -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vector. Names of fleets in the assessment model as shortened in the output file or names of fleets to replace the native fleet names in the output. For example, if fleet names in the model are 1, 2, 3 then fleet_names = c("fleet1" = 1, "fleet2" = 2, "fleet3" = 3). -Default: NULL} +Default: NULL + +Should match length of \code{files}.} } \value{ Reshaped data frame. diff --git a/man/convert_output.Rd b/man/convert_output.Rd index 782b50e7..50ec9a5e 100644 --- a/man/convert_output.Rd +++ b/man/convert_output.Rd @@ -4,24 +4,32 @@ \alias{convert_output} \title{Convert Output} \usage{ -convert_output(file, model = NULL, fleet_names = NULL, save_dir = NULL) +convert_output(files, models = NULL, fleet_names = NULL, save_dir = NULL) } \arguments{ -\item{file}{Path. Assessment model output file path. Currently accepts SS3 -\code{r4ss::ss_output()} or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, and FIMS model object.} +\item{files}{List of Paths. Assessment model output file paths. Currently accepts SS3 +\code{r4ss::ss_output()} or Report.sso file (being deprecated), BAM .rda file, Rceattle model object, +and FIMS model object. If multiple elements, all valid models will be read, converted, and +appended together. -\item{model}{String. Assessment model used in evaluation +\code{names(files)} will be used as the name of the model in the output.} + +\item{models}{Character vector Assessment model used in evaluation Default: NULL -Options: "ss3", "bam", "fims", "rceattle"} +Options: "ss3", "bam", "fims", "rceattle" + +Should match length of \code{files}.} -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vector. Names of fleets in the assessment model as shortened in the output file or names of fleets to replace the native fleet names in the output. For example, if fleet names in the model are 1, 2, 3 then fleet_names = c("fleet1" = 1, "fleet2" = 2, "fleet3" = 3). -Default: NULL} +Default: NULL + +Should match length of \code{files}.} \item{save_dir}{Path. Full file path to save the converted output file. If saved file name is not indicated, the file will be saved as "std_output.rda" @@ -50,6 +58,12 @@ convert_output( fleet_names = c("TWL", "NONTWL"), save_dir = here::here("standard_output.rda") ) +convert_output( + file = list("model1"=here::here("model1", "Report.sso", "model2"=here::here("model2", "Report.sso")), + model = c("ss3", "ss3"), + fleet_names = list("model1"=c("TWL", "NONTWL"), "model2"=c("Fishery1", "Survey1", "Survey2")), + save_dir = here::here("standard_output.rda") +) } } \author{ From c3cfea6a0605fdfc21504460406e886abf343821 Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Mon, 9 Nov 2026 11:16:22 -0500 Subject: [PATCH 16/17] fix: Swicth erroneous %>% to |> format --- R/utils_plot.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils_plot.R b/R/utils_plot.R index 9991a703..6400b5c6 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -742,7 +742,7 @@ filter_data <- function( } if (nrow(plot_data) < 1) cli::cli_abort("{label_name} not found.") if (is.null(group)) { - if (!is.data.frame(dat) || (plot_data %>% dplyr::distinct(model) %>% nrow) > 1) { + if (!is.data.frame(dat) || (plot_data |> dplyr::distinct(model) |> nrow()) > 1) { plot_data <- plot_data |> dplyr::mutate( group_var = as.character(.data[["model"]]) @@ -1180,7 +1180,7 @@ add_reference_line <- function( dat = if(n_models == 1){ dat } else { - dat %>% dplyr::filter(model == model_names[i]) + dat |> dplyr::filter(model == model_names[i]) }, reference_name = glue::glue("{label}_{ref_line[i]}"), lbs = lbs @@ -1195,7 +1195,7 @@ add_reference_line <- function( } if ("unfished" %in% names(ref_line_x)) { - sel_dat <- dat %>% dplyr::filter(model == model_names[i]) + sel_dat <- dat |> dplyr::filter(model == model_names[i]) plt_lab <- label # find the minimum x axis value from the plot min_year <- sel_dat |> From 31d39715ed6a2baeec966284216790249a02be1d Mon Sep 17 00:00:00 2001 From: Joshua Zahner Date: Fri, 13 Nov 2026 10:58:18 -0500 Subject: [PATCH 17/17] mend --- tests/testthat/test-convert_output.R | 22 +++++++++++----------- tests/testthat/test-convert_output_fims.R | 2 +- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/testthat/test-convert_output.R b/tests/testthat/test-convert_output.R index 72d99e07..30fd3890 100644 --- a/tests/testthat/test-convert_output.R +++ b/tests/testthat/test-convert_output.R @@ -80,7 +80,7 @@ test_that("missing arguments trigger warnings or errors", { expect_error( convert_output( file = fs::path("fixtures", "ss3_models", "models", "Hake_2018", "Report.rdat"), - model = "ss3", + models = "ss3", save_dir = fs::path("fixtures", "ss3_models_converted", "Hake_2018") ), "`file` not found" @@ -147,11 +147,11 @@ test_that("convert_output works for Rceattle", { # Both documented input modes: a path, and an already-loaded fit. expect_no_error(from_path <- convert_output( file = fit_path, - model = "rceattle" + models = "rceattle" )) expect_no_error(from_object <- convert_output( file = readRDS(fit_path), - model = "rceattle" + models = "rceattle" )) expect_equal(dim(from_path)[2], 36) @@ -186,7 +186,7 @@ test_that("convert_output works for Rceattle", { test_that("convert_output places Rceattle selectivity and M at age", { fit <- readRDS(test_path("fixtures", "rceattle_goa_atf.rds")) - out <- convert_output(file = fit, model = "rceattle") + out <- convert_output(file = fit, models = "rceattle") # One row per fleet, sex, age and year of sel_at_age, and each cell lands # on its own fleet, sex, age and year. @@ -218,7 +218,7 @@ test_that("convert_output places Rceattle selectivity and M at age", { # The age dimension is the bin index, so the ages start at minage. fit[["data_list"]][["minage"]] <- 3 - shifted <- convert_output(file = fit, model = "rceattle") + shifted <- convert_output(file = fit, models = "rceattle") expect_equal( range(as.numeric(shifted[shifted[["label"]] == "natural_mortality", ][["age"]])), c(3, 23) @@ -230,7 +230,7 @@ test_that("convert_output places Rceattle selectivity and M at age", { test_that("convert_output gives Rceattle recruitment deviations a standard error", { fit <- readRDS(test_path("fixtures", "rceattle_goa_atf.rds")) - out <- convert_output(file = fit, model = "rceattle") + out <- convert_output(file = fit, models = "rceattle") # The standard error of a fixed effect is the square root of its diagonal # entry in cov.fixed. @@ -252,7 +252,7 @@ test_that("convert_output gives Rceattle recruitment deviations a standard error random_rec[["sdrep"]][["par.fixed"]] <- fit[["sdrep"]][["par.fixed"]][!is_rec_dev] random_rec[["sdrep"]][["cov.fixed"]] <- fit[["sdrep"]][["cov.fixed"]][!is_rec_dev, !is_rec_dev] - random_out <- convert_output(file = random_rec, model = "rceattle") + random_out <- convert_output(file = random_rec, models = "rceattle") random_rec_devs <- random_out[random_out[["label"]] == "recruitment_deviations", ] expect_equal(random_rec_devs[["estimate"]], rec_devs[["estimate"]]) expect_equal(random_rec_devs[["uncertainty"]], rec_dev_sd) @@ -265,7 +265,7 @@ test_that("convert_output accepts .RDS as well as .rds for Rceattle", { upper <- tempfile(fileext = ".RDS") on.exit(unlink(upper), add = TRUE) saveRDS(readRDS(test_path("fixtures", "rceattle_goa_atf.rds")), upper) - expect_no_error(convert_output(file = upper, model = "rceattle")) + expect_no_error(convert_output(file = upper, models = "rceattle")) }) test_that("convert_output says so when an Rceattle fit carries no sdrep", { @@ -277,7 +277,7 @@ test_that("convert_output says so when an Rceattle fit carries no sdrep", { # Matched on a single word, since cli wraps a message and a phrase can be # split across a line break. expect_warning( - out <- convert_output(file = no_sd, model = "rceattle"), + out <- convert_output(file = no_sd, models = "rceattle"), "sdrep" ) expect_false("biomass" %in% out[["label"]]) @@ -291,7 +291,7 @@ test_that("convert_output refuses an Rceattle fit of unknown species count", { no_nspp[["data_list"]][["nspp"]] <- NULL expect_error( - convert_output(file = no_nspp, model = "rceattle"), + convert_output(file = no_nspp, models = "rceattle"), "species count is unknown" ) }) @@ -305,7 +305,7 @@ test_that("convert_output refuses a multispecies Rceattle fit", { # Matched on a phrase short enough that cli's wrapping cannot split it. expect_error( - convert_output(file = multi, model = "rceattle"), + convert_output(file = multi, models = "rceattle"), "Rceattle model has 3 species" ) }) diff --git a/tests/testthat/test-convert_output_fims.R b/tests/testthat/test-convert_output_fims.R index 1b25ecc7..436190a0 100644 --- a/tests/testthat/test-convert_output_fims.R +++ b/tests/testthat/test-convert_output_fims.R @@ -4,7 +4,7 @@ fims_estimates <- function() { readRDS(test_path("fixtures", "fims_output", "fims_estimates.rds")) } convert_fims <- function(dat = fims_estimates(), ...) { - suppressMessages(convert_output(dat, model = "fims", ...)) + suppressMessages(convert_output(dat, models = "fims", ...)) } test_that("FIMS data points are split into observed and predicted rows", {