diff --git a/R/conout_bam.R b/R/conout_bam.R index 83215146..de474334 100644 --- a/R/conout_bam.R +++ b/R/conout_bam.R @@ -3,6 +3,10 @@ #' Does not change naming conventions. #' #' @inheritParams convert_output +#' +#' @param Path. Assessment model output file path. Currently accepts SS3 +#' Report.sso file, BAM .rda file, Rceattle model object, and FIMS model object. +#' #' @param out_new The empty standard output data frame from #' [convert_output()], which sets the columns of the output. #' diff --git a/R/conout_rceattle.R b/R/conout_rceattle.R index 117fdae4..15cd81b0 100644 --- a/R/conout_rceattle.R +++ b/R/conout_rceattle.R @@ -3,6 +3,10 @@ #' Does not change naming conventions. #' #' @inheritParams convert_output +#' +#' @param Path. Assessment model output file path. Currently accepts SS3 +#' Report.sso file, BAM .rda file, Rceattle model object, and FIMS model object. +#' #' @param out_new The empty standard output data frame from #' [convert_output()], which sets the columns of the output. #' diff --git a/R/conout_ss3.R b/R/conout_ss3.R index 6ca8ec69..d68c80bc 100644 --- a/R/conout_ss3.R +++ b/R/conout_ss3.R @@ -4,6 +4,10 @@ #' file or returned object from `r4ss::ss_output()`. #' #' @inheritParams convert_output +#' +#' @param Path. Assessment model output file path. Currently accepts SS3 +#' Report.sso file, BAM .rda file, Rceattle model object, and FIMS model object. +#' #' @param out_new The empty standard output data frame from #' [convert_output()], which sets the columns of the output. #' @@ -281,7 +285,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)) } } } @@ -328,7 +332,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( diff --git a/R/convert_output.R b/R/convert_output.R index d3b2ac99..52363789 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -2,20 +2,31 @@ #' #' 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 output -#' (the tibble returned by `FIMS::get_estimates()`, a `FIMSFit` object, or an .rds file with either). -#' @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 output (the tibble returned by `FIMS::get_estimates()`, a `FIMSFit` object, or an .rds +#' file with either). 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 vectors. 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. @@ -55,191 +66,281 @@ #' 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( - file, - model = NULL, + files, + models = NULL, fleet_names = NULL, save_dir = NULL, start_year = 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" - ) - ) + + # 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) || is.data.frame(files)){ + cli::cli_alert("`files` appears to represent a single model. Converting to list object.") + files <- list(files) + names(files) <- "model_1" } - - # 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") - } + + 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=\",\")}")) } - #### 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, ] + 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)}")) + } - # 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 + + 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", + 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") } - ) - 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}" - )) } - } - } - # 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.") + #### 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 ) - } - } else if (is.null(model)) { - model <- switch(class(file)[1], - "FIMSFit" = { - cli::cli_alert_info("Processing FIMS output file...") - "fims" - }, - "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" + 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 { - cli::cli_alert_info("Processing SS3 r4ss output file...") - "ss3" + if (!file.exists(file)) { + cli::cli_abort(c( + message = "`file` not found.", + "i" = "`file` entered as {file}" + )) + } } - }, - 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(models)) { + 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 if (is.null(models)){ + model <- switch(class(file)[1], + "FIMSFit" = { + cli::cli_alert_info("Processing FIMS output file...") + "fims" + }, + "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.") + ) + }else{ + model <- models[i] + } + + #### 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") { + out_new <- conout_fims(file = file, out_new = out_new, start_year = start_year) + #### 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." + )) + } + + # 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, + year=as.character(year), + month=as.character(month), + block=as.character(block), + fleet=as.character(fleet) + ) + 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") { - out_new <- conout_fims(file = file, out_new = out_new, start_year = start_year) - #### 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 @@ -273,48 +374,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 @@ -328,5 +387,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 diff --git a/R/utils_plot.R b/R/utils_plot.R index 691b52fd..6400b5c6 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) { @@ -892,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"]] @@ -1178,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 @@ -1205,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 |> @@ -1222,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 @@ -1231,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 ) ) diff --git a/man/conout_bam.Rd b/man/conout_bam.Rd index c6ad6e9b..6cb63143 100644 --- a/man/conout_bam.Rd +++ b/man/conout_bam.Rd @@ -14,12 +14,17 @@ conout_bam(file, out_new, fleet_names = NULL) \item{out_new}{The empty standard output data frame from \code{\link[=convert_output]{convert_output()}}, which sets the columns of the output.} -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vectors. 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{Path.}{Assessment model output file path. Currently accepts SS3 +Report.sso file, BAM .rda file, Rceattle model object, and FIMS model object.} } \value{ Reshaped data frame. diff --git a/man/conout_rceattle.Rd b/man/conout_rceattle.Rd index b8fe6762..9e9e3734 100644 --- a/man/conout_rceattle.Rd +++ b/man/conout_rceattle.Rd @@ -14,12 +14,17 @@ conout_rceattle(file, out_new, fleet_names = NULL) \item{out_new}{The empty standard output data frame from \code{\link[=convert_output]{convert_output()}}, which sets the columns of the output.} -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vectors. 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{Path.}{Assessment model output file path. Currently accepts SS3 +Report.sso file, BAM .rda file, Rceattle model object, and FIMS model object.} } \value{ Reshaped data frame. diff --git a/man/conout_ss3.Rd b/man/conout_ss3.Rd index 0c259a8e..8fdd5c43 100644 --- a/man/conout_ss3.Rd +++ b/man/conout_ss3.Rd @@ -14,12 +14,17 @@ conout_ss3(file, out_new, fleet_names = NULL) \item{out_new}{The empty standard output data frame from \code{\link[=convert_output]{convert_output()}}, which sets the columns of the output.} -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +\item{fleet_names}{List of Character vectors. 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{Path.}{Assessment model output file path. Currently accepts SS3 +Report.sso file, BAM .rda file, Rceattle model object, and FIMS model object.} } \value{ Reshaped data frame. diff --git a/man/convert_output.Rd b/man/convert_output.Rd index b409306e..30d010e4 100644 --- a/man/convert_output.Rd +++ b/man/convert_output.Rd @@ -4,31 +4,33 @@ \alias{convert_output} \title{Convert Output} \usage{ -convert_output( - file, - model = NULL, - fleet_names = NULL, - save_dir = NULL, - start_year = 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 output -(the tibble returned by \code{FIMS::get_estimates()}, a \code{FIMSFit} object, or an .rds file with either).} +\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 output (the tibble returned by \code{FIMS::get_estimates()}, a \code{FIMSFit} object, or an +.rds file with either). If multiple elements, all valid models will be read, converted, and +appended together. + +\code{names(files)} will be used as the name of the model in the output.} -\item{model}{String. Assessment model used in evaluation +\item{models}{Character vector Assessment model used in evaluation Default: NULL -Options: "ss3", "bam", "fims", "rceattle"} +Options: "ss3", "bam", "fims", "rceattle" -\item{fleet_names}{Character vector. Names of fleets in the assessment model as +Should match length of \code{files}.} + +\item{fleet_names}{List of Character vectors. 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" @@ -71,6 +73,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{ diff --git a/tests/testthat/test-convert_output.R b/tests/testthat/test-convert_output.R index 51d111c5..30fd3890 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 = r4ss::SS_output(file.path(all_models[1])) ) - expect_equal(dim(output)[2], 35) + expect_equal(dim(output)[2], 36) }) test_that("convert_output does not emit scalar case_when deprecation warning", { @@ -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" @@ -93,14 +93,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", { @@ -147,14 +147,14 @@ 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], 35) + expect_equal(dim(from_path)[2], 36) expect_equal(from_path, from_object) # Every row says which module it came from. @@ -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,33 @@ 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" ) }) + +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")) +}) + 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", { 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) }) 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) + +}) 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..5e633c51 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 @@ -163,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