diff --git a/NAMESPACE b/NAMESPACE index 69dfc105..4b9e32c5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(add_theme) export(convert_output) +export(create_latex_table) export(create_rda) export(export_rda) export(extract_caps_alttext) @@ -22,7 +23,9 @@ export(plot_spawning_biomass) export(plot_stock_recruitment) export(plot_timeseries) export(process_data) +export(process_table) export(reference_line) export(save_all_plots) +export(table_landings) export(theme_noaa) export(write_captions) diff --git a/R/add_theme.R b/R/add_theme.R index e3074bfa..5b4578cd 100644 --- a/R/add_theme.R +++ b/R/add_theme.R @@ -29,9 +29,12 @@ add_theme <- function(x, discrete = TRUE) { flextable::align(align = "center", part = "body") |> flextable::autofit() # FitFlextableToPage() - } else if (class(x)[1] == "gt_tbl") { - theme_obj <- x + } else if (class(x)[1][1] == "gt_tbl") { # gt object + theme_obj <- x |> + gt::cols_align(align = "center") |> + gt::tab_style(style = gt::cell_text(weight = "bold"), + locations = gt::cells_column_labels()) } else if (class(x)[1] == "kableExtra" | as.character(class(x)[2]) == "knitr_kable") { theme_obj <- x } else if (class(x)[1] == "gg" | class(x)[2] == "ggplot") { # - removed bc wouldn't work with only 1 entry in the class for other object classes diff --git a/R/convert_output.R b/R/convert_output.R index 632af573..a31f7caf 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -149,7 +149,7 @@ convert_output <- function( blank.lines.skip = FALSE ) # Check SS3 model version - vers <- stringr::str_extract(dat[1, 1], "[0-9].[0-9][0-9].[0-9][0-9].[0-9]") + vers <- stringr::str_extract(dat[1, 1], "[0-9].[0-9][0-9].[0-9][0-9]") # .[0-9] if (vers < 3.3) { cli::cli_abort("This function in its current state can not process the data.") } @@ -1056,8 +1056,24 @@ convert_output <- function( row <- row[row != "XX"] df1 <- df1[, -loc_xx] } + + # TODO: apply this next if statement to a general process so it's part of the standard cleaning + # check if the headers make sense + # this is a temporary fix to a specific bug + # I have seen this issue in the past and I am not sure how to recognize this generally + if (any(parm_sel == "AGE_SELEX" & c("1","2", "3") %notin% row)) { + rownum <- prodlim::row.match(row, df1) + # Subset data frame + df1 <- df1[-c(1:rownum), ] + cols_to_keep <- which(sapply(df1, function(x) !all(is.na(x)))) + df1 <- df1 |> dplyr::select(dplyr::all_of(c(names(cols_to_keep)))) + df2 <- df1[stats::complete.cases(df1), ] + row <- df2[1, ] + } + # make row the header names for first df colnames(df1) <- row + # find row number that matches 'row' rownum <- prodlim::row.match(row, df1) # Subset data frame diff --git a/R/plot_biomass_at_age.R b/R/plot_biomass_at_age.R index 92b84ca7..1c3f671d 100644 --- a/R/plot_biomass_at_age.R +++ b/R/plot_biomass_at_age.R @@ -73,6 +73,7 @@ plot_biomass_at_age <- function( group <- processed_data[[2]] facet <- processed_data[[3]] } + # Check for extracted data, if not return warning and empty plot if (nrow(b) == 0) { cli::cli_alert_warning("No data found for biomass at age. Please check the input data.") diff --git a/R/plot_indices.R b/R/plot_indices.R index 65935a9c..6725555c 100644 --- a/R/plot_indices.R +++ b/R/plot_indices.R @@ -15,8 +15,8 @@ #' plot_indices( #' dat = stockplotr:::example_data, #' unit_label = "fish/hr", -#' interactive = FALSE -#' ) +#' interactive= FALSE) +#' plot_indices <- function( dat, unit_label = "", @@ -115,7 +115,7 @@ plot_indices <- function( if (make_rda) { create_rda( object = plt, - topic_label = "indices", + topic_label = "CPUE.indices", fig_or_table = "figure", dat = dat, dir = figures_dir, diff --git a/R/plot_landings.R b/R/plot_landings.R index 00680212..0a04cf0f 100644 --- a/R/plot_landings.R +++ b/R/plot_landings.R @@ -111,4 +111,5 @@ plot_landings <- function( } # Output final plot plt + } diff --git a/R/plot_natural_mortality.R b/R/plot_natural_mortality.R index 79da8b02..303f665e 100644 --- a/R/plot_natural_mortality.R +++ b/R/plot_natural_mortality.R @@ -82,7 +82,6 @@ plot_natural_mortality <- function( dplyr::mutate(group_var = .data[[group]]) } - plt <- plot_timeseries( dat = processed_data |> dplyr::mutate(age = as.numeric(age)), x = "age", diff --git a/R/plot_recruitment.R b/R/plot_recruitment.R index 29a0f190..24c4715f 100644 --- a/R/plot_recruitment.R +++ b/R/plot_recruitment.R @@ -4,7 +4,7 @@ #' @param unit_label units for recruitment #' #' @return Plot recruitment over time from an assessment model output file -#' translated to a standardized output (\link[asar]{convert_output}). There are options to return a +#' translated to a standardized output (\link[stockplotr]{convert_output}). There are options to return a #' [ggplot2::ggplot()] object or export an rda object containing associated #' caption and alternative text for the figure. #' @export diff --git a/R/process_data.R b/R/process_data.R index e20afbfd..0f475b39 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -1,4 +1,8 @@ -#' Post processing of filtered data +################################## +# Post processing of filtered data +################################## + +#' Processing for figures #' #' @param dat Pre-filtered data from \link[stockplotr]{filter_data} following a #' long format data. @@ -62,6 +66,7 @@ process_data <- function( group <- "none" } } + # check for additional indexed variables index_variables <- check_grouping(dat) # If user input "none" to group this makes the plot remove any facetting or summarize? @@ -117,6 +122,7 @@ process_data <- function( } else { data <- dat } + if (length(index_variables) > 0) { data <- data |> dplyr::select(tidyselect::all_of(c( @@ -138,6 +144,7 @@ process_data <- function( if ("age" %in% colnames(data) && any(!is.na(data$age))) { # subset out nas if ages exist for this # not sure if this works for all cases -- are there situations where we want the NA and not age? + data <- dplyr::filter(data, !is.na(age)) if (!is.null(group) && group == "age") { if ("age" %in% index_variables) index_variables <- index_variables[-grep("age", index_variables)] @@ -193,13 +200,6 @@ process_data <- function( facet <- c(facet, index_variables) } } else if (length(index_variables) > 0) { - # overwrite variable if a grouping/indexing column was identified - # based on only the first group if >1 identified - # variable <- ifelse( - # length(unique(data[[index_variables[1]]])) > 1, - # TRUE, - # FALSE - # ) # Move remaining indexing variables to facet if (!is.null(group) && group == "year") { facet <- c(facet, index_variables) @@ -294,12 +294,6 @@ process_data <- function( data <- data |> dplyr::filter(year == max(year)) } } - # check if all values are the same - # variable <- ifelse( - # length(unique(data$estimate)) != length(unique(data$age)), - # TRUE, # more M values than ages - # FALSE # same # or less M values than ages - # ) } # Final check if group = NULL, then set group var to 1 @@ -317,6 +311,7 @@ process_data <- function( group <- NULL } } + # Export list of objects list( # variable, @@ -325,3 +320,197 @@ process_data <- function( facet ) } + +#------------------------------------------------------------------------------- + +#' Processing for tables +#' +#' @inheritParams process_data +#' @param label A string or vector of strings identifying the label values to filter the data. +#' +#' @returns A dataframe of processed data ready for formatting into a table. Input is an object created with \link[stockplotr]{filter_data}. +#' @export +#' +#' @examples { +#' filtered <- filter_data( +#' dat = stockplotr:::example_data, +#' label_name = "landings", +#' geom = "line", +#' era = "time" +#' ) +#' process_table(dat = filtered, method = "sum") +#' } +process_table <- function( + dat, + group = NULL, + method = "sum", + label = NULL){ + + index_variables <- c() + # TODO: incorporate this into the output for check_grouping to avoid loop + for (mod in unique(dat$model)) { + mod_data <- dplyr::filter(dat, model == mod) + mod_index <- check_grouping(mod_data) + mod_names <- rep(mod, length(mod_index)) + mod_index <- setNames(mod_index, mod_names) + index_variables <- c(index_variables, mod_index) + } + + id_group <- index_variables[-grep("year|age|length_bin", index_variables)] + cols <- index_variables[grep("year|age|length_bin", index_variables)] + + # Add check for length label >1 + # below method will only work when unqiue(label) == 2 + if (!is.null(label)) { + dat <- dat |> + dplyr::filter(label %in% label) + } else { + # Check if there's > 1 label for any model + if ((dat |> + dplyr::group_by(model) |> + dplyr::summarise(unique_count = dplyr::n_distinct(label)) |> + dplyr::pull(unique_count) |> max()) > 1){ + if ((dat |> + dplyr::group_by(model) |> + dplyr::summarise(unique_count = dplyr::n_distinct(label)) |> + dplyr::pull(unique_count) |> max()) == 2){ + # compare estimate across all indexing vars and see if they are different over years + #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + dat <- check_label_differences(dat, index_variables) + } else { + cli::cli_alert_info("Multiple labels detected.") + if (interactive()) { + options <- c() + for (i in seq_along(unique(dat$label))) { + options[i] <- paste0(unique(dat$label)[i]) + } + question1 <- utils::select.list( + options, + multiple = TRUE, + title = "Select one or more of the following label names" + ) + selected_label <- intersect( + unique(dat$label), + question1 + ) + } else { + cli::cli_alert_info("Non-interactive session detected. Using the first label: {unique(prepared_data$label)[1]}") + selected_label <- unique(dat$label)[1] + } + dat <- dat |> + dplyr::filter(label %in% selected_label) + + # Re-run index variables after filtering + index_variables <- c() + # TODO: incorporate this into the output for check_grouping to avoid loop + for (mod in unique(dat$model)) { + mod_data <- dplyr::filter(dat, model == mod) + mod_index <- check_grouping(mod_data) + mod_names <- rep(mod, length(mod_index)) + mod_index <- setNames(mod_index, mod_names) + index_variables <- c(index_variables, mod_index) + } + + id_group <- index_variables[-grep("year|age|length_bin", index_variables)] + cols <- index_variables[grep("year|age|length_bin", index_variables)] + + # Check if any of the selected labels are the same values + dat <- check_label_differences(dat, index_variables, id_group) + } # close else >2 labels + } # close if >1 label in df + } # close if label == NULL + + #TODO: calculate error properly, if summarized + if (!is.null(group) && group == "none"){ + dat <- switch( + method, + "mean" = dat |> + dplyr::group_by(dplyr::across(tidyselect::all_of(c("label", "model", index_variables)))) |> + dplyr::summarize( + estimate = mean(estimate), + uncertainty_label = unique(uncertainty_label), + uncertainty = mean(uncertainty) + ), + "sum" = dat |> + dplyr::group_by(dplyr::across(tidyselect::all_of(c("label", "model", index_variables)))) |> + dplyr::summarize( + estimate = sum(estimate), + uncertainty_label = unique(uncertainty_label), + uncertainty = sum(uncertainty) + ) + ) + } else if (!is.null(group)) { + # check if grouping is in index_variables + if (group %notin% index_variables) { + cli::cli_alert_warning("Selected `group` not present within the data.") + cli::cli_alert_info("Output will contain indexing variables ({index_variables}).") + } + } + + uncert_lab <- unique(dat$uncertainty_label) + estimate_lab <- stringr::str_to_title(stringr::str_replace_all(unique(dat$label), "_", " ")) + + table_list <- list() + id_group_list <- list() + for (mod in unique(dat$model)){ + mod_dat <- dplyr::filter(dat, model == mod) + mod_index_variables <- check_grouping(mod_dat) + mod_id_group <- mod_index_variables[-grep("year|age|length_bin", mod_index_variables)] + mod_cols <- mod_index_variables[grep("year|age|length_bin", mod_index_variables)] + mod_uncert_lab <- unique(mod_dat$uncertainty_label) + if (length(mod_uncert_lab) == 1 && is.na(mod_uncert_lab)) { + mod_uncert_lab <- "Uncertainty" + } else { + uncert_lab <- stats::na.omit(uncert_lab) + } + + table_data <- mod_dat |> + dplyr::filter(dplyr::if_all(dplyr::any_of(mod_cols), ~ !is.na(.))) |> + dplyr::rename_with( + ~ stringr::str_to_title(.x), + .cols = dplyr::all_of(mod_index_variables) + ) |> + dplyr::select(dplyr::all_of(c( + stringr::str_to_title(mod_index_variables), "label", "estimate", "uncertainty" + ))) |> + # rename uncertainty and capitalize indexing variables + estimate + dplyr::rename( + !!mod_uncert_lab := uncertainty + ) |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c(stringr::str_to_title(mod_cols))), + values_from = dplyr::all_of(c("estimate", mod_uncert_lab)), + names_from = dplyr::all_of(c("label", stringr::str_to_title(mod_id_group))) + ) |> + dplyr::rename_with(~ stringr::str_remove(., "^estimate_")) + + # group indexing data together (i.e. fleet) + if (length(mod_id_group) > 0){ + for (f in unique(mod_dat$fleet)) { # TODO: change dat$fleet to indexing col(s) + table_data <- table_data |> + dplyr::relocate(dplyr::contains(f), .after = dplyr::last_col()) + } + } + table_list[[mod]] <- table_data + + # This feels like backward progress + id_group_list[[mod]] <- lapply(setNames(mod_id_group, mod_id_group), function(x) { + unique(mod_dat[[x]]) + }) + } # close loop + + # check if only one model -- export as df instead + # if (length(table_list) == 1){ + # table_list <- table_list[[1]] + # } + + # Export as list + list( + table_list, + stringr::str_to_title(id_group), + id_group_list + ) + +} diff --git a/R/save_all_plots.R b/R/save_all_plots.R index 230d2ac1..0c9eb348 100644 --- a/R/save_all_plots.R +++ b/R/save_all_plots.R @@ -39,6 +39,7 @@ #' @param catch_unit_label Abbreviated units for catch #' @param catch_scale_amount A number describing how much to scale down the #' catch quantities shown via bubble size. See `recruitment_scale_amount`. +#' @param landings_unit_label Units for landings #' @param proportional T/F to scale size of bubble plots #' #' @return Rda files for each figure/table. @@ -56,42 +57,42 @@ #' ) #' } save_all_plots <- function( - # imported from plot_recruitment - dat, - recruitment_unit_label = "mt", # changed from unit_label to recruitment_unit_label for specificity - recruitment_scale_amount = 1, - relative = FALSE, - proportional = TRUE, - interactive = FALSE, - figures_tables_dir = getwd(), - # imported from plot_biomass - ref_line = "msy", - biomass_scale_amount = 1, - # imported from plot_landings - landings_unit_label = "mt", - # imported from plot_recruitment_deviations- zero unique arguments - # imported from plot_stock_recruitment - spawning_biomass_label = "mt", - spawning_biomass_scale_amount = 1, - # imported from plot_spawning_biomass - ref_line_sb = "msy", - # imported from plot_abundance_at_age - abundance_at_age_scale_amount = 1, - abundance_at_age_unit_label = "fish", - # imported from plot_biomass_at_age - biomass_at_age_scale_amount = 1, - biomass_at_age_unit_label = "mt", - # imported from plot_indices - indices_unit_label = "", - # imported from table_afsc_tier- add potential unique arguments after dev - # imported from table_bnc - biomass_unit_label = "mt", - catch_unit_label = "mt", - catch_scale_amount = 1 - # imported from table_harvest_projection- add potential unique arguments after dev - # imported from table_indices- zero unique arguments - # imported from table_landings- zero unique arguments -) { + # imported from plot_recruitment + dat, + recruitment_unit_label = "mt", # changed from unit_label to recruitment_unit_label for specificity + recruitment_scale_amount = 1, + relative = FALSE, + proportional = TRUE, + interactive = FALSE, + figures_tables_dir = getwd(), + # imported from plot_biomass + ref_line = "msy", + biomass_scale_amount = 1, + # imported from plot_landings + landings_unit_label = "mt", + # imported from plot_recruitment_deviations- zero unique arguments + # imported from plot_stock_recruitment + spawning_biomass_label = "mt", + spawning_biomass_scale_amount = 1, + # imported from plot_spawning_biomass + ref_line_sb = "msy", + # imported from plot_abundance_at_age + abundance_at_age_scale_amount = 1, + abundance_at_age_unit_label = "fish", + # imported from plot_biomass_at_age + biomass_at_age_scale_amount = 1, + biomass_at_age_unit_label = "mt", + # imported from plot_indices + indices_unit_label = "", + # imported from table_afsc_tier- add potential unique arguments after dev + # imported from table_bnc + biomass_unit_label = "mt", + catch_unit_label = "mt", + catch_scale_amount = 1 + # imported from table_harvest_projection- add potential unique arguments after dev + # imported from table_indices- zero unique arguments + # imported from table_landings- zero unique arguments + ) { make_rda <- TRUE cli::cli_h1("Starting export of figures and tables") @@ -105,7 +106,8 @@ save_all_plots <- function( dat, unit_label = recruitment_unit_label, scale_amount = recruitment_scale_amount, - interactive = interactive, + interactive = FALSE, + module = "TIME_SERIES", make_rda = TRUE, figures_dir = figures_tables_dir ) #|> @@ -151,31 +153,69 @@ save_all_plots <- function( ) - # tryCatch( - # { - # cli::cli_h2("plot_landings") - # plot_landings(dat, - # unit_label = landings_unit_label, - # make_rda, - # figures_dir = figures_tables_dir - # ) # |> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # cli::cli_alert_danger("plot_landings failed to run.") - # cli::cli_alert("Tip: check that your arguments are correct.") - # cli::cli_li("landings_unit_label = {landings_unit_label}") - # print(e) - # } - # ) + tryCatch( + { + cli::cli_h2("plot_landings") + plot_landings(dat, + unit_label = landings_unit_label, + make_rda = TRUE, + figures_dir = figures_tables_dir, + interactive = FALSE + ) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_landings failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("landings_unit_label = {landings_unit_label}") + print(e) + } + ) + + tryCatch( + { + cli::cli_h2("plot_fishing_mortality") + plot_fishing_mortality(dat, + make_rda = TRUE, + relative = relative, + figures_dir = figures_tables_dir, + interactive = FALSE) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_fishing_mortality failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("relative = {relative}") + print(e) + } + ) + + tryCatch( + { + cli::cli_h2("plot_natural_mortality") + plot_natural_mortality(dat, + module = "Natural_Mortality", + make_rda = TRUE, + figures_dir = figures_tables_dir, + interactive = FALSE) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_natural_mortality failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + print(e) + } + ) tryCatch( { cli::cli_h2("plot_recruitment_deviations") plot_recruitment_deviations( dat, - interactive = interactive, + interactive = FALSE, make_rda = TRUE, figures_dir = figures_tables_dir ) #|> @@ -189,11 +229,26 @@ save_all_plots <- function( } ) - # plot_stock_recruitment(dat, - # spawning_biomass_label, - # recruitment_label = recruitment_unit_label, - # make_rda, - # figures_dir = figures_tables_dir)# |> suppressWarnings() |> invisible() + tryCatch( + { + cli::cli_h2("plot_stock_recruitment") + plot_stock_recruitment(dat, + spawning_biomass_label, + recruitment_label = recruitment_unit_label, + make_rda = TRUE, + interactive = FALSE, + module = "SPAWN_RECRUIT", + figures_dir = figures_tables_dir) + # |> suppressWarnings() |> invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_stock_recruitment failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("spawning_biomass_label = {spawning_biomass_label}") + cli::cli_li("recruitment_label = {recruitment_label}") + print(e) + } + ) tryCatch( { @@ -252,7 +307,7 @@ save_all_plots <- function( unit_label = catch_unit_label, scale_amount = catch_scale_amount, proportional = proportional, - interactive = interactive, + interactive = FALSE, make_rda = TRUE, figures_dir = figures_tables_dir ) # |> @@ -260,7 +315,11 @@ save_all_plots <- function( # invisible() }, error = function(e) { - message("plot_catch_comp failed to run. Tip: check that your arguments are correct.") + message("plot_catch_comp failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("catch_unit_label = {catch_unit_label}") + cli::cli_li("catch_scale_amount = {catch_scale_amount}") + cli::cli_li("proportional = {proportional}") print(e) } ) @@ -280,20 +339,31 @@ save_all_plots <- function( # invisible() }, error = function(e) { - cli::cli_alert_danger("plot_biomass_at_age failed to run.") + cli::cli_alert_danger("plot_biomass_at_age failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("biomass_at_age_unit_label = {biomass_at_age_unit_label}") + cli::cli_li("biomass_at_age_scale_amount = {biomass_at_age_scale_amount}") + print(e) + } + ) + + tryCatch( + { + cli::cli_h2("plot_indices") + plot_indices(dat, + unit_label = indices_unit_label, + make_rda = TRUE, + interactive = FALSE, + figures_dir = figures_tables_dir)# |> suppressWarnings() |> invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_indices failed to run.") cli::cli_alert("Tip: check that your arguments are correct.") - cli::cli_li("biomass_at_age_unit_label = {biomass_at_age_unit_label}") - cli::cli_li("biomass_at_age_scale_amount = {biomass_at_age_scale_amount}") + cli::cli_li("indices_unit_label = {indices_unit_label}") print(e) } ) - # uncomment when this is working properly - # plot_indices(dat, - # unit_label = indices_unit_label, - # make_rda, - # figures_dir = figures_tables_dir)# |> suppressWarnings() |> invisible() - # tables # tryCatch( # { @@ -303,7 +373,7 @@ save_all_plots <- function( # biomass_unit_label, # catch_unit_label, # spawning_biomass_label, - # make_rda, + # make_rda = TRUE, # tables_dir = figures_tables_dir # ) # |> # # suppressWarnings() |> @@ -324,7 +394,7 @@ save_all_plots <- function( # cli::cli_h2("table_indices") # table_indices( # dat, - # make_rda, + # make_rda = TRUE, # tables_dir = figures_tables_dir # ) # |> # # suppressWarnings() |> @@ -342,7 +412,7 @@ save_all_plots <- function( # cli::cli_h2("table_landings") # table_landings(dat, # unit_label = landings_unit_label, - # make_rda, + # make_rda = TRUE, # tables_dir = figures_tables_dir # ) # |> # # suppressWarnings() |> diff --git a/R/table_landings.R b/R/table_landings.R index 599debe0..efa714ce 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -1,207 +1,136 @@ -# #' Landed catch by fleet and year table -# #' -# #' @inheritParams plot_recruitment -# #' @param unit_label Abbreviated units of landings -# #' @param tables_dir The location of the folder containing the generated table -# #' rda files ("tables") that will be created if the argument `make_rda` = TRUE. -# #' Default is the working directory. -# #' -# #' @return Create a table ready for a stock assessment report of landed catch by -# #' fleet and year. -# #' @export -# #' -# #' @examples -# #' \dontrun{ -# #' table_landings(dat) -# #' -# #' table_landings( -# #' dat, -# #' unit_label = "landings label", -# #' end_year = 2024, -# #' make_rda = TRUE, -# #' tables_dir = getwd() -# #' ) -# #' } -# table_landings <- function(dat, -# unit_label = "mt", -# end_year = format(Sys.Date(), "%Y"), -# make_rda = FALSE, -# tables_dir = getwd()) { -# # TODO: add an option to stratify by gear type - -# # Units -# land_label <- glue::glue("Landings ({unit_label})") - -# # create plot-specific variables to use throughout fxn for naming and IDing -# topic_label <- "landings" - -# # identify output -# fig_or_table <- "table" - -# # check year isn't past end_year if not projections plot -# check_year( -# end_year = end_year, -# fig_or_table = fig_or_table, -# topic = topic_label -# ) - -# # read standard data file and extract target quantity -# land_dat <- dat |> -# dplyr::filter( -# c(module_name == "t.series" & grepl("landings_observed", label)) | c(module_name == "CATCH" & grepl("ret_bio", label)), -# # t.series is associated with a conversion from BAM output and CATCH with SS3 converted output -# !is.na(fleet) -# ) |> -# dplyr::mutate( -# estimate = as.numeric(estimate), -# year = as.numeric(year) -# ) |> -# suppressWarnings() |> -# dplyr::filter( -# !is.na(year) -# ) |> -# dplyr::filter(year <= end_year) - - -# # if (is.numeric(land_dat$fleet)){ -# # land_dat$fleet <- paste0("00", land_dat$fleet) -# # } - -# if ("uncertainty" %in% names(land_dat)) { -# if ("uncertainty_label" %in% names(land_dat)) { -# uncert_label <- land_dat |> -# dplyr::select(uncertainty_label) |> -# unique() |> -# as.character() |> -# toupper() - -# land_dat <- land_dat |> -# dplyr::mutate(uncertainty = round(uncertainty, 2)) - -# if (uncert_label != "NA") { -# land_dat <- land_dat |> -# dplyr::rename(!!(uncert_label) := "uncertainty") - -# piv_vals <- c( -# "Landings", -# uncert_label -# ) -# } else { -# uncert_label <- NULL -# piv_vals <- "Landings" -# } -# } -# } else { -# uncert_label <- NULL -# piv_vals <- "Landings" -# } - -# # TODO: Reorder column names so that numeric fleets show up in chronological -# # order (currently, lists 1, 10, 11, 12, etc.) - -# # Check number of areas and season - if any are >1 then need to use alternative plot (or summarize) -# narea <- length(unique(land_dat$area)) -# nseas <- length(unique(land_dat$season)) - -# if (narea > 1) { -# # factors <- TRUE -# idcols <- c("year", "Area") -# # will need facet if TRUE -# } else { -# idcols <- c("year") -# # factors <- FALSE -# } - -# # Check for nseas > 1 - mean of landings through the year -# if (nseas > 1) { -# land_dat <- land_dat |> -# dplyr::group_by(year, fleet, sex, area, growth_pattern) |> -# dplyr::summarize(estimate = mean(estimate)) |> -# dplyr::mutate(fleet = as.factor(fleet)) |> -# dplyr::rename("Area" = area) -# } - -# # Extract fleet names -# fleet_names <- unique(as.character(land_dat$fleet)) - -# land <- land_dat |> -# dplyr::mutate( -# fleet = as.factor(fleet), -# # fleet = paste0("Fleet_", fleet), -# year = as.factor(year), -# estimate = round(estimate, digits = 0) -# ) |> -# dplyr::rename("Landings" = estimate) |> -# dplyr::relocate(fleet, .after = season) |> -# tidyr::pivot_wider( -# id_cols = dplyr::all_of(idcols), -# names_from = fleet, -# # names_prefix = "Fleet_", -# values_from = piv_vals, -# names_glue = "Fleet {fleet}_{.value}" -# ) |> -# dplyr::rename("Year" = year) - -# land <- land |> -# dplyr::select(order(colnames(land), -# method = "auto" -# )) |> -# dplyr::relocate(Year, .before = 1) |> -# dplyr::rename_with(~ stringr::str_replace( -# ., -# "Landings", -# land_label -# )) - -# # add theming to final table -# final <- land |> -# flextable::flextable() |> -# flextable::separate_header() |> -# flextable::merge_h(part = "header") |> -# flextable::align(part = "header") |> -# add_theme() |> -# suppressWarnings() -# final - -# # export figure to rda if argument = T -# if (make_rda == TRUE) { -# # run write_captions.R if its output doesn't exist -# if (!file.exists( -# fs::path(getwd(), "captions_alt_text.csv") -# ) -# ) { -# stockplotr::write_captions( -# dat = dat, -# dir = tables_dir, -# year = end_year -# ) -# } - -# # add more key quantities included as arguments in this fxn -# add_more_key_quants( -# dat, -# topic = topic_label, -# fig_or_table = fig_or_table, -# dir = tables_dir, -# end_year = end_year, -# units = unit_label -# ) - -# # extract this plot's caption and alt text -# caps_alttext <- extract_caps_alttext( -# topic_label = topic_label, -# fig_or_table = fig_or_table, -# dir = tables_dir -# ) - -# export_rda( -# object = final, -# caps_alttext = caps_alttext, -# figures_tables_dir = tables_dir, -# topic_label = topic_label, -# fig_or_table = fig_or_table -# ) -# } -# # Return finished table -# final -# } +#' Landed catch by fleet and year table +#' +#' @inheritParams plot_recruitment +#' @param unit_label Abbreviated units of landings +#' @param group A string identifying the indexing variable of the data. If you +#' want to just summarize the data across all factors, set group = "none". +#' @param method A string describing the method of summarizing data when group +#' is set to "none". Options are "sum" or "mean". Default is "sum". +#' @param tables_dir The location of the folder containing the generated table +#' rda files ("tables") that will be created if the argument `make_rda` = TRUE. +#' @param label The label that will be chosen from the input file. If unspecified, +#' the function will search the "label" column and use the first matching label +#' in this ordered list: "landings_weight", "landings_numbers", "landings_expected", +#' "landings_predicted", "landings". +#' +#' @return Create a table ready for a stock assessment report of landed catch by +#' fleet and year. +#' @export +#' +#' @examples +#' table_landings(stockplotr::example_data) +#' +#' table_landings( +#' stockplotr::example_data, +#' unit_label = "landings label", +#' group = +#' ) +table_landings <- function( + dat, + unit_label = "mt", + era = NULL, + interactive = TRUE, + group = NULL, + method = "sum", + module = NULL, + label = NULL, + make_rda = FALSE, + tables_dir = getwd()) { + + #TODO: do group and facet need to be uncommented and updated? + # Filter data for landings + prepared_data <- filter_data( + dat = dat, + label_name = "landings", + geom = "line", + era = era, + module = module, + scale_amount = 1, + interactive = interactive + ) |> + dplyr::mutate(estimate = round(as.numeric(estimate), digits = 0)) |> + dplyr::mutate(uncertainty = round(as.numeric(uncertainty), digits = 2)) + + # Add check if there is any data + if (nrow(prepared_data) == 0){ + cli::cli_abort("No landings data found.") + } + + # get uncertainty label by model + uncert_lab <- prepared_data |> + dplyr::filter(!is.na(uncertainty_label)) |> + dplyr::group_by(model) |> + dplyr::reframe(unique_uncert = unique(uncertainty_label)) # changed to reframe -- may cause errors + uncert_lab <- stats::setNames(uncert_lab$unique_uncert, uncert_lab$model) + # if (length(unique(uncert_lab)) == 1) uncert_lab <- unique(uncert_lab) # might need this line + + # This needs to be adjusted when comparing different models and diff error + if (length(uncert_lab) > 1 & length(unique(uncert_lab)) == 1 | length(names(uncert_lab)) == 1){ # prepared_data$model + # cli::cli_alert_warning("More than one value for uncertainty exists: {uncert_lab}") + uncert_lab <- uncert_lab[[1]] + # cli::cli_alert_warning("The first value ({uncert_lab}) will be chosen.") + } + + if (is.na(uncert_lab)) uncert_lab <- "uncertainty" + + # get fleet names + # TODO: change from fleets to id_group AFTER the process data step and adjust throughout the table based on indexing + fleets <- unique(prepared_data$fleet) |> + # sort numerically even if fleets are 100% characters + stringr::str_sort(numeric = TRUE) + + #TODO: fix this so that fleet names aren't removed if, e.g., group = "fleet" + table_data_info <- process_table( + dat = prepared_data, + # group = group, + method = method, + label = label + ) + table_data <- table_data_info[[1]] + indexed_vars <- table_data_info[[2]] + id_col_vals <- table_data_info[[3]] + + # id_group_vals <- sapply(id_cols, function(x) unique(prepared_data[[x]]), simplify = FALSE) + # TODO: add check if there is a landings column for every error column -- if not remove the error (can keep landings) + + # merge error and landings columns and rename + df_list <- merge_error( + table_data, + uncert_lab, + fleets, + label = "landings", + unit_label + ) + + # transform dfs into tables + final <- lapply(df_list, function(df) { + df |> + gt::gt() |> + add_theme() + }) + + # export figure to rda if argument = T + if (make_rda == TRUE) { + create_rda( + object = final, + topic_label = "landings", + fig_or_table = "table", + dat = dat, + dir = tables_dir, + scale_amount = 1, + unit_label = unit_label, + table_df = final_df + ) + } + # Send table(s) to viewer + if (!is.data.frame(table_data)) { + for(t in final) { + print(t) + } + # Return table list invisibly + return(invisible(final)) + } else { + # Return finished table (when only one table) + return(final) + } +} diff --git a/R/utils_plot.R b/R/utils_plot.R index 5242aef0..bd276c4f 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -199,10 +199,190 @@ plot_timeseries <- function( #' "sex", "area", etc.). Currently can only have one level of grouping. #' @param facet a string or vector of strings of a column that facets the data #' (e.g. "year", "area", etc.) -#' @param hline indicate true or false to place a horizontal line at 1 #' @param ... inherited arguments from internal functions from ggplot2::geom_xx #' #' +#' @returns Create a time series plot for a stock assessment report. The user +#' has options to create a line, point, or area plot where the x-axis is year +#' and Y can vary for any time series quantity. Currently, grouping is +#' restricted to one group where faceting can be any number of facets. +#' @export +#' +#' @examples +#' \dontrun{ +#' plot_timeseries(dat, +#' x = "year", +#' y = "estimate", +#' geom = "line", +#' xlab = "Year", +#' ylab = "Biomass", +#' group = "fleet", +#' facet = "area") +#' } +plot_timeseries <- function( + dat, + x = "year", + y = "estimate", + geom = "line", + xlab = "Year", + ylab = NULL, + group = NULL, + facet = NULL, + ... +) { + # Start plot + plot <- ggplot2::ggplot() + # make into new geom? + # more defaults and fxnality for ggplot + + # Add geom + plot <- switch( + geom, + "point" = { + point_size = ifelse( + is.null(list(...)$size), + 2.0, + list(...)$size + ) + plot + + ggplot2::geom_point( + data = dat, + ggplot2::aes( + .data[[x]], + .data[[y]], + # TODO: add more groupings + # shape = ifelse(any(grepl("shape", names(group))), .data[[group[[grep("shape", names(group))]]]], 1), + # color = ifelse(any(grepl("color", names(group))), .data[[group[[grep("color", names(group))]]]], "black") + color = model, + shape = group_var + ), + # size = point_size, + ... + ) + }, + "line" = { + plot + + ggplot2::geom_ribbon( + dat = dat|> dplyr::filter(!is.na(estimate_lower)), + ggplot2::aes( + x = .data[[x]], + ymin = estimate_lower, + ymax = estimate_upper + ), + colour = "grey", + alpha = 0.3 + ) + + ggplot2::geom_line( + data = dat, + ggplot2::aes( + .data[[x]], + .data[[y]], + linetype = group_var, + # linetype = ifelse(!is.null(group), group_var, "solid"), + color = model + ), + # linewidth = 1.0, + ... + ) + }, + "area" = { + plot + + ggplot2::geom_area( + data = dat, + ggplot2::aes( + x = .data[[x]], + y = .data[[y]], + fill = model + ), + ... + ) + } + ) + + # Add labels to axis and legend + labs <- plot + ggplot2::labs( + x = xlab, + y = ylab, + color = "Model", + linetype = cap_first_letter(group), + fill = cap_first_letter(group), + shape = cap_first_letter(group) + ) + + # Remove linetype or point when there is no grouping + if (is.null(group)) { + labs <- switch( + geom, + "line" = labs + ggplot2::guides(linetype = "none"), + "point" = labs + ggplot2::guides(shape = "none"), + # return plot if option beyond line and point for now + labs + ) + } + if (length(unique(dat$model)) == 1){ + labs <- switch( + geom, + "line" = labs + ggplot2::guides(color = "none"), + "point" = labs + ggplot2::guides(color = "none"), + "area" = labs + ggplot2::guides(fill = "none"), + # return plot if option beyond line and point for now + labs + ) + } + + # Calc axis breaks + x_n_breaks <- axis_breaks(dat[[x]]) + breaks <- ggplot2::scale_x_continuous( + breaks = x_n_breaks, + guide = ggplot2::guide_axis( + minor.ticks = TRUE + ) + ) + + # Put together final plot + final <- labs + breaks + ggplot2::expand_limits(y = 0) + + ggplot2::scale_y_continuous( + labels = scales::label_comma() + ) + + # Remove legend if no group is selected + if (is.null(group) & is.data.frame(dat) & any(is.na(unique(dat$model)))) { + final <- final + ggplot2::theme(legend.position = "none") + } + + # Check if facet(s) are desired + if (!is.null(facet)) { + facet <- paste("~", paste(facet, collapse = " + ")) + facet_formula <- stats::reformulate(facet) + + final <- final + ggplot2::facet_wrap(facet_formula) + } + final +} + +#------------------------------------------------------------------------------ + +#' Create plot with error +#' +#' @param dat filtered data frame from standard output file(s) preformatted for +#' the target label from \link[stockplotr]{prepare_data} +#' @param x a string of the column name of data used to plot on the x-axis (default +#' is "year") +#' @param y a string of the column name of data used to plot on the y-axis (default +#' is "estimate") +#' @param geom type of geom to use for plotting found in ggplot2 (e.g. "point", +#' "line", etc.). Default is "line". Other options are "point" and "area". +#' @param xlab a string of the x-axis label (default is "Year") +#' @param ylab a string of the y-axis label. If NULL, it will be set to the name +#' of `y`. +#' @param group a string of a single column that groups the data (e.g. "fleet", +#' "sex", "area", etc.). Currently can only have one level of grouping. +#' @param facet a string or vector of strings of a column that facets the data +#' (e.g. "year", "area", etc.) +#' @param hline indicate true or false to place a horizontal line at 1 +#' @param ... inherited arguments from internal functions from ggplot2::geom_xx +#' +#' plot_error <- function( dat, x = "year", @@ -950,7 +1130,7 @@ check_grouping <- function(dat) { "fleet", "sex", "area", "growth_pattern", "month", "season", "platoon", "bio_pattern", - "settlement", "morph", "block" + "settlement", "morph", "block", "length_bins" ) # Create emppty vector dat_index <- c() diff --git a/R/utils_rda.R b/R/utils_rda.R index 95d7265a..45492202 100644 --- a/R/utils_rda.R +++ b/R/utils_rda.R @@ -17,6 +17,8 @@ #' shown on the y axis. For example, scale_amount = 100 would scale down a value #' from 500,000 --> 5,000. This scale will be reflected in the y axis label. #' @param unit_label A string containing a unit label for the y-axis +#' @param table_df The data frame that the table will be made into for purposes +#' of exporting a latex formatted table. #' #' @returns Create an rda package for a plot or table object. Requires an #' object from the R environment such as a ggplot or flextable object. @@ -41,7 +43,8 @@ create_rda <- function( ref_line = "msy", ref_point = "msy", # this is not used anywhere scale_amount = 1, - unit_label = "mt" + unit_label = "mt", + table_df = NULL ) { # run write_captions.R if its output doesn't exist if (!file.exists( @@ -82,13 +85,21 @@ create_rda <- function( fig_or_table = fig_or_table, dir = dir ) + + if (fig_or_table == "table") { + latex_table <- create_latex_table( + data = table_df, + caption = caps_alttext[1], + label = "landings_latex") + } export_rda( object = object, caps_alttext = caps_alttext, # Load in of this is missing I think figures_tables_dir = dir, topic_label = topic_label, - fig_or_table = fig_or_table + fig_or_table = fig_or_table, + latex_table = latex_table ) } @@ -115,6 +126,8 @@ add_more_key_quants <- function( # make year character if not null if (!is.null(end_year)) { end_year <- as.character(end_year) + } else { + end_year <- format(Sys.Date(), "%Y") } # select specific fig/table's caption/alt text @@ -137,43 +150,43 @@ add_more_key_quants <- function( # calculate key quantities that rely on end_year for calculation ## terminal fishing mortality - if (topic_cap_alt$label == "fishing.mortality") { - if (is.null(dat)) { - cli::cli_alert_warning("Some key quantities associated with fishing mortality were not extracted and added to captions_alt_text.csv due to missing data file (i.e., 'dat' argument).", wrap = TRUE) - } else { - F.end.year <- dat |> - dplyr::filter( - c(label == "fishing_mortality" & - year == end_year) | - c(label == "terminal_fishing_mortality" & is.na(year)) - ) |> - dplyr::pull(estimate) |> - as.numeric() |> - round(digits = 2) - - # COMMENTING OUT THESE LINES because the current alt text/captions csv - # doesn't include Ftarg or F.Ftarg. If we alter them to include them, - # then uncomment these lines and add code that would substitute the key - # quantities into the df, like at the bottom of write_captions. - # - # # recalculate Ftarg for F.Ftarg, below - # Ftarg <- dat |> - # dplyr::filter(grepl('f_target', label) | - # grepl('f_msy', label) | - # c(grepl('fishing_mortality_msy', label) & - # is.na(year))) |> - # dplyr::pull(estimate) |> - # as.numeric() |> - # round(digits = 2) - # - # # Terminal year F respective to F target - # F.Ftarg <- F.end.year / Ftarg - - if (!is.null(F.end.year)) { - end_year <- as.character(F.end.year) - } - } - } + # if (topic_cap_alt$label == "fishing.mortality") { + # if (is.null(dat)) { + # cli::cli_alert_warning("Some key quantities associated with fishing mortality were not extracted and added to captions_alt_text.csv due to missing data file (i.e., 'dat' argument).", wrap = TRUE) + # } else { + # F.end.year <- dat |> + # dplyr::filter( + # c(label == "fishing_mortality" & + # year == end_year) | + # c(label == "terminal_fishing_mortality" & is.na(year)) + # ) |> + # dplyr::pull(estimate) |> + # as.numeric() |> + # round(digits = 2) + # + # # COMMENTING OUT THESE LINES because the current alt text/captions csv + # # doesn't include Ftarg or F.Ftarg. If we alter them to include them, + # # then uncomment these lines and add code that would substitute the key + # # quantities into the df, like at the bottom of write_captions. + # # + # # # recalculate Ftarg for F.Ftarg, below + # # Ftarg <- dat |> + # # dplyr::filter(grepl('f_target', label) | + # # grepl('f_msy', label) | + # # c(grepl('fishing_mortality_msy', label) & + # # is.na(year))) |> + # # dplyr::pull(estimate) |> + # # as.numeric() |> + # # round(digits = 2) + # # + # # # Terminal year F respective to F target + # # F.Ftarg <- F.end.year / Ftarg + # + # if (!is.null(F.end.year)) { + # end_year <- as.character(F.end.year) + # } + # } + # } # calculate key quantities that rely on scaling for calculation @@ -1821,6 +1834,7 @@ extract_caps_alttext <- function(topic_label = NULL, #' labels are found in the "label" column of the "captions_alt_text.csv" file #' and are used to link the figure or table with its caption/alt text. #' @param fig_or_table A string describing whether the plot is a figure or table. +#' @param latex_table The object containing a LaTeX-based table. #' #' @return An rda file with a figure's ggplot, caption, and alternative text, or #' a table's flextable and caption. @@ -1834,7 +1848,8 @@ extract_caps_alttext <- function(topic_label = NULL, #' caps_alttext = caps_alttext_object, #' figures_tables_dir = here::here(), #' topic_label = "bnc", -#' fig_or_table = "table" +#' fig_or_table = "table", +#' latex_table = "latex_table" #' ) #' #' export_rda( @@ -1849,7 +1864,8 @@ export_rda <- function(object = NULL, caps_alttext = NULL, figures_tables_dir = NULL, topic_label = NULL, - fig_or_table = NULL) { + fig_or_table = NULL, + latex_table = NULL) { # make rda for figures if (fig_or_table == "figure") { rda <- list( @@ -1869,7 +1885,8 @@ export_rda <- function(object = NULL, } else if (fig_or_table == "table") { rda <- list( "table" = object, - "caption" = caps_alttext[[1]] + "caption" = caps_alttext[[1]], + "latex_table" = latex_table ) rda_loc <- "tables" # check if a tables folder already exists; if not, make one diff --git a/R/utils_table.R b/R/utils_table.R new file mode 100644 index 00000000..ce6502da --- /dev/null +++ b/R/utils_table.R @@ -0,0 +1,316 @@ +############################## +# Utility functions for tables +############################## + +#' Create the rda package for a plot or table +#' +#' @param data A dataframe-based table +#' @param caption A string comprising the table caption +#' @param label A string comprising the table label +#' +#' @returns A table based in LaTeX. +#' @export +#' +#' @examples +#' create_latex_table( +#' data = as.data.frame(head(mtcars, 6)), +#' caption = "My caption", +#' label = "My label" +#' ) +create_latex_table <- function(data, + caption, + label) { + + # Essential latex packages: + # \usepackage{hyperref} + # \usepackage{bookmark} + # \usepackage{booktabs} + # \usepackage{tagpdf} + # \usepackage{caption} + + latex_tbl <- knitr::kable(data, + format = "latex", + booktabs = TRUE, + linesep = "") + + # add number of header rows + nheaders <- 1 + + init_line <- paste0("\\tagpdfsetup{table/header-rows={", nheaders, "}}") + + # add caption, label + cap <- paste0("\\captionof{table}{", caption, "}\n") + lab <- paste0("\\label{", label, "}\n") + + # put together table + table <- paste0(init_line, + "\n", + "\\begin{center}\n", + cap, + lab, + latex_tbl, + "\n", + "\\end{center}") + + table + + # ncols <- ncol(data) + # column_names <- paste(colnames(data), collapse = " & ") + # latex_format_data <- paste( + # column_names, "\\\\", "\n" + # ) + # + # # c signifies all cols will be centered + # alignment <- strrep("c", ncols) + # + # for (i in 1:nrow(data)) { + # row_data <- stringr::str_replace_all( + # paste(data[i,], collapse = " & "), + # "NA", + # "-") + # + # # ends up adding a space and two forward slashes to the end of each line + # row_data_with_linebreak <- paste0(row_data, " \\\\") + # + # latex_format_data <- paste( + # latex_format_data, + # ifelse(i == 1, "\\midrule\n", ""), + # row_data_with_linebreak, "\n", + # # row_data, "\n", + # sep = "", + # collapse = "\n" + # ) + # } + # + # table <- paste0( + # # "\\begin{document}\n", + # "\\begin{tabular}{", alignment, "}\n", + # cap, + # lab, + # "\\toprule\n", + # # multicolumn needs to = number of columns in the data set + # "\\multicolumn{", ncols, "}{c}{Example} \\\\ \n",# example is the first header - not sure we want bc it's a merged cell + # # headers and values separated by '&' ending with 2 trailing forward slashes + # latex_format_data, + # "\\bottomrule\n", + # "\\end{tabular}\n", + # collapse = "\n" + # ) +} + +#------------------------------------------------------------------------------- + +#' Create loop to test for differences in column values +#' @param dat input data into process_table +#' @param index_variables the index_variables vector created within process_table +#' @param id_group the identifying index variable as a string + +check_label_differences <- function(dat, index_variables, id_group = NULL) { + # Loop over model to perform checks if the model columns are identical + for (mod in unique(dat$model)){ + mod_index_variables <- unique(index_variables[names(index_variables) == mod]) + mod_data <- dplyr::filter(dat, model == mod) + mod_id_group <- unique(id_group[names(id_group) == mod]) + + if (length(unique(mod_data$label)) == 1) { + # only one label - nothing to edit for this model + next + } else if (length(unique(mod_data$label)) == 2) { + label_differences <- mod_data |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(mod_index_variables), + names_from = label, + values_from = estimate + ) |> + dplyr::mutate( + diff = .data[[unique(mod_data$label)[1]]] - .data[[unique(mod_data$label)[2]]] + ) + + if (all(label_differences$diff == 0)){ + # Modify dat to only include one label from model + cli::cli_alert_info("Labels in {mod} model have identical values. Using only: {unique(mod_data$label)[2]}") + dat <- dat |> + dplyr::filter(label != unique(mod_data$label)[1]) + } + } else { + label_differences <- mod_data |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(unique(mod_index_variables)), + names_from = label, + values_from = estimate + ) + + # Identify if any of the aligned columns contain ID group -- if so warn user and remove id_group labels from table + empty_check <- label_differences |> + dplyr::filter(dplyr::if_all(dplyr::any_of(mod_id_group), ~ !is.na(.))) |> + dplyr::summarise(dplyr::across(unique(mod_data$label), ~ all(is.na(.)))) + col_to_remove <- names(empty_check)[which(as.logical(empty_check))] + mod_data2 <- dplyr::filter(mod_data, label %notin% col_to_remove) + # Identify if any of the columns are identical then remove one of the identical columns + if (length(unique(mod_data2$label)) == 2){ + # compare estimate across all indexing vars and see if they are different over years + label_differences <- mod_data2 |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c(mod_index_variables)), + names_from = label, + values_from = estimate + ) |> + dplyr::mutate( + diff = .data[[unique(mod_data2$label)[1]]] - .data[[unique(mod_data2$label)[2]]] + ) + + if (all(label_differences$diff == 0)){ + cli::cli_alert_info("Labels in {mod} model have identical values. Using only one label: {unique(prepared_data$label)[2]}") + col_to_remove <- c(col_to_remove, unique(mod_data2$label)[1]) + } + dat <- dplyr::filter(dat, label %notin% col_to_remove) + } else { + cli::cli_alert_danger("Multiple labels with differing values detected. Function may not work as intended. Please leave an issue on GitHub.") + } + } + } + dat +} + +#------------------------------------------------------------------------------- + +#' Rename columns and merge estimate and uncertainty columns for table presentation +#' +#' @param table_data list of dataframes that will be eventually turned into tables +#' @param uncert_lab uncertainty label. Typically inherited from another function +#' but is the exact string of the uncertainty in the data (e.g., "sd", "se", "cv", +#' "uncertainty").) +#' @param fleets Vector of fleet names. +#' @param label Label name of target quantity that is being presented by the table. +#' @param unit_label String. The units of the estimate being presented in the table. +#' +#' @return List of formatted dataframes that contain column names formatted +#' for a table along with a merge of values in the estimate and error columns +#' to reduce redundancy in the table. +#' +merge_error <- function(table_data, uncert_lab, fleets, label, unit_label) { + # TODO: change fleets to grouping when the data is indexed by factors other than fleet + lapply(table_data, function(tab_dat) { + + label_cols_init <- colnames(tab_dat)[ + grepl(label, tolower(colnames(tab_dat))) # "landings" + ] + + # CONDITION: Only proceed if label columns actually exist in this data frame + if (length(label_cols_init) > 0) { + # Clean up fleet names and keywords + label_cols_new <- stringr::str_remove_all( + label_cols_init, + paste0("_", fleets, collapse = "|") + ) |> stringr::str_replace_all("_", " ") + # Drop "weight" or "number" if present + label_cols_new <- unique( + stringr::str_remove_all(tolower(label_cols_new), " number| weight") + ) + # Check if we should simplify to a single "Landings" label + if (length(unique(label_cols_new)) == 2) { + matches <- sapply(uncert_lab, function(l) { + any(stringr::str_detect(label_cols_new, stringr::str_c("\\b", l, "\\b"))) + }) + id_uncert <- uncert_lab[matches] + if (length(id_uncert) == 0) id_uncert <- "uncertainty" + + label_cols_final <- c( + ifelse( + id_uncert == "uncertainty", + paste0(stringr::str_to_title(label), " (", unit_label, ")"), + paste0(stringr::str_to_title(label), " (", unit_label, ") (", id_uncert, ")") + ), + id_uncert) + if (id_uncert != uncert_lab) uncert_lab <- id_uncert + # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column + } else if (any(grepl("expected|predicted|observed|estimated",label_cols_new))) { + label_lab <- stringr::str_to_title(unique(stringr::str_extract( + label_cols_new, + paste(label, c("expected", "predicted", "observed", "estimated"), collapse = "|")) + )) + id_uncert_col <- paste0( + uncert_lab, " ", label_lab) + if (uncert_lab == "uncertainty" || length(uncert_lab) == 0) { + label_cols_final <- c(paste0(label_lab, " (", unit_label, ")"), uncert_lab) + } else { + label_cols_final <- c( + paste0(label_lab, " (", unit_label, ") (", uncert_lab, ")"), + id_uncert_col) + } + } + + # Re-attach fleet names to the new labels + cols_fleets <- stringr::str_extract( + label_cols_init, + paste0("_",fleets, "$", collapse = "|") + ) |> stringr::str_remove_all("_") + + # Target labels for next step + final_names <- ifelse( + is.na(cols_fleets), + label_cols_new, + paste0(label_cols_new, " - ", cols_fleets) + ) + + # Assign previous names with new identifying ones + rename_map <- stats::setNames(label_cols_init, final_names) + + # rename cols for final df + rename_map_final <- stats::setNames( + final_names, + ifelse( + is.na(cols_fleets), + label_cols_final, + paste0(label_cols_final, " - ", cols_fleets) + )) + + # Apply the renaming + tab_dat <- tab_dat |> + dplyr::rename(dplyr::any_of(rename_map)) + + # Identify lestimate and uncertainty columns for loop and other reference + label_cols <- names(tab_dat)[-c(1, grep(glue::glue("^{uncert_lab} "), names(tab_dat)))] + uncert_cols <- names(tab_dat)[grep(glue::glue("^{uncert_lab} "), names(tab_dat))] + # Comment out from here to closing brackets if don't want to combine label and uncertainty + # {{ ------------------------------------------------------------------- + # Use loop to combine label (uncertainty) + for (l_col in label_cols) { + + # Identify the error column that contains l_col in the name + uncert_col <- uncert_cols[grepl(l_col, uncert_cols)] + + # adjust tab dat to combine the uncert_col value into the l_col = l_col (uncert_col) + tab_dat <- tab_dat |> + dplyr::mutate( + !!l_col := ifelse( + !is.na(.data[[uncert_col]]), + paste0(.data[[l_col]], " (", .data[[uncert_col]], ")"), + # maybe not good practice to insert dash? + ifelse( + is.na(.data[[l_col]]), + "-", + as.character(.data[[l_col]]) + ) + ) + ) |> + # Remove uncertainty colummn id'd in this step of the loop + dplyr::select(-dplyr::all_of(uncert_col)) + } # close loop combining label and uncertainty + # }} ------------------------------------------------------------------- + + # Rename final df with cleaned names + tab_dat <- tab_dat |> + dplyr::rename(any_of(rename_map_final)) |> + dplyr::rename_with(~ gsub("_", " - ", .)) # |> + # not sure if we want to keep this or not + # dplyr::select(where(~!all(is.na(.)) | !all(. == "-"))) # remove columns that are all NA or all "-")) + } else { + cli::cli_alert_info( + "No {label} columns found in data; skipping renaming step." + ) + } # close if statement on label column + return(tab_dat) + }) # close and end lapply +} + diff --git a/inst/resources/captions_alt_text_template.csv b/inst/resources/captions_alt_text_template.csv index 54f30f85..6bdab07e 100644 --- a/inst/resources/captions_alt_text_template.csv +++ b/inst/resources/captions_alt_text_template.csv @@ -3,6 +3,7 @@ kobe,figure,"Kobe plot showing stock status. Triangles delineate start and end y biomass,figure,Biomass (B) time series. The horizontal dashed line represents the limit reference point (B.ref.pt B.units).,"Line graph showing biomass time series. The x axis shows the year, which spans from B.start.year to B.end.year . The y axis shows biomass in B.units, which spans from B.min to B.max." relative.biomass,figure,Relative biomass (B) time series. The horizontal dashed line represents the limit reference point calculated as B/B(reference point) (B.ref.point B.units).,"Line graph showing relative biomass time series. The x axis shows the year, which spans from B.start.year to B.end.year . The y axis shows relative biomass (B/B~target~), which spans from rel.B.min to rel.B.max B.units ." fishing.mortality,figure,Fishing mortality (F) over time. The horizontal dashed line represents the target reference point (F.ref.pt).,"Line graph showing fishing mortality over time . The x axis shows the year, which spans from F.start.year to F.end.year . The y axis shows fishing mortality in F.units, which spans from F.min to F.max." +relative.fishing.mortality,figure,Relative fishing mortality (F) over time. The horizontal dashed line represents the target reference point (F.ref.pt).,"Line graph showing fishing mortality over time . The x axis shows the year, which spans from F.start.year to F.end.year . The y axis shows relative fishing mortality (F/F~target~), which spans from rel.F.min to rel.F.max." landings,figure,Historical landings by fleet.,"Cumulative area plot showing historical landings. The x axis shows the year, which spans from landings.start.year to landings.end.year . The y axis shows landings in landings.units, which spans from landings.min to landings.max." natural.mortality,figure,Natural mortality (M) for each age. ,"Line graph showing natural mortality. The x axis shows age in years, which spans from M.age.min to M.age.max. The y axis shows the natural mortality rate per year, which spans from M.rate.min to M.rate.max." vonb.laa,figure,Aged and measured fish (points) and von Bertalanffy growth function (line) fit to the data.,"Point and line graph showing observations of measured age and length data as points and the von Bertalanffy relationship fit to this data as a line with 95% confidence intervals. The x axis shows age in years, which spans from vonb.age.min to vonb.age.max. The y axis shows length in vonb.length.units, which spans from vonb.length.min to vonb.length.max." diff --git a/man/check_label_differences.Rd b/man/check_label_differences.Rd new file mode 100644 index 00000000..06dc1dfc --- /dev/null +++ b/man/check_label_differences.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_table.R +\name{check_label_differences} +\alias{check_label_differences} +\title{Create loop to test for differences in column values} +\usage{ +check_label_differences(dat, index_variables, id_group = NULL) +} +\arguments{ +\item{dat}{input data into process_table} + +\item{index_variables}{the index_variables vector created within process_table} + +\item{id_group}{the identifying index variable as a string} +} +\description{ +Create loop to test for differences in column values +} diff --git a/man/create_latex_table.Rd b/man/create_latex_table.Rd new file mode 100644 index 00000000..ea557e7c --- /dev/null +++ b/man/create_latex_table.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_table.R +\name{create_latex_table} +\alias{create_latex_table} +\title{Create the rda package for a plot or table} +\usage{ +create_latex_table(data, caption, label) +} +\arguments{ +\item{data}{A dataframe-based table} + +\item{caption}{A string comprising the table caption} + +\item{label}{A string comprising the table label} +} +\value{ +A table based in LaTeX. +} +\description{ +Create the rda package for a plot or table +} +\examples{ +create_latex_table( + data = as.data.frame(head(mtcars, 6)), + caption = "My caption", + label = "My label" +) +} diff --git a/man/create_rda.Rd b/man/create_rda.Rd index c34f0964..1c9db268 100644 --- a/man/create_rda.Rd +++ b/man/create_rda.Rd @@ -14,7 +14,8 @@ create_rda( ref_line = "msy", ref_point = "msy", scale_amount = 1, - unit_label = "mt" + unit_label = "mt", + table_df = NULL ) } \arguments{ @@ -40,6 +41,9 @@ shown on the y axis. For example, scale_amount = 100 would scale down a value from 500,000 --> 5,000. This scale will be reflected in the y axis label.} \item{unit_label}{A string containing a unit label for the y-axis} + +\item{table_df}{The data frame that the table will be made into for purposes +of exporting a latex formatted table.} } \value{ Create an rda package for a plot or table object. Requires an diff --git a/man/export_rda.Rd b/man/export_rda.Rd index 0b3d2daa..273ff6b5 100644 --- a/man/export_rda.Rd +++ b/man/export_rda.Rd @@ -9,7 +9,8 @@ export_rda( caps_alttext = NULL, figures_tables_dir = NULL, topic_label = NULL, - fig_or_table = NULL + fig_or_table = NULL, + latex_table = NULL ) } \arguments{ @@ -29,6 +30,8 @@ labels are found in the "label" column of the "captions_alt_text.csv" file and are used to link the figure or table with its caption/alt text.} \item{fig_or_table}{A string describing whether the plot is a figure or table.} + +\item{latex_table}{The object containing a LaTeX-based table.} } \value{ An rda file with a figure's ggplot, caption, and alternative text, or @@ -45,7 +48,8 @@ export_rda( caps_alttext = caps_alttext_object, figures_tables_dir = here::here(), topic_label = "bnc", - fig_or_table = "table" + fig_or_table = "table", + latex_table = "latex_table" ) export_rda( diff --git a/man/merge_error.Rd b/man/merge_error.Rd new file mode 100644 index 00000000..d119b126 --- /dev/null +++ b/man/merge_error.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_table.R +\name{merge_error} +\alias{merge_error} +\title{Rename columns and merge estimate and uncertainty columns for table presentation} +\usage{ +merge_error(table_data, uncert_lab, fleets, label, unit_label) +} +\arguments{ +\item{table_data}{list of dataframes that will be eventually turned into tables} + +\item{uncert_lab}{uncertainty label. Typically inherited from another function +but is the exact string of the uncertainty in the data (e.g., "sd", "se", "cv", +"uncertainty").)} + +\item{fleets}{Vector of fleet names.} + +\item{label}{Label name of target quantity that is being presented by the table.} + +\item{unit_label}{String. The units of the estimate being presented in the table.} +} +\value{ +List of formatted dataframes that contain column names formatted +for a table along with a merge of values in the estimate and error columns +to reduce redundancy in the table. +} +\description{ +Rename columns and merge estimate and uncertainty columns for table presentation +} diff --git a/man/plot_error.Rd b/man/plot_error.Rd index d34bb491..d1386808 100644 --- a/man/plot_error.Rd +++ b/man/plot_error.Rd @@ -19,21 +19,21 @@ plot_error( } \arguments{ \item{dat}{filtered data frame from standard output file(s) preformatted for -the target label from \link[stockplotr]{filter_data}} +the target label from \link[stockplotr]{prepare_data}} -\item{x}{a string of the column name of data used to plot on the x-axis (default +\item{x}{a string of the column name of data used to plot on the x-axis (default is "year")} -\item{y}{a string of the column name of data used to plot on the y-axis (default +\item{y}{a string of the column name of data used to plot on the y-axis (default is "estimate")} -\item{geom}{type of geom to use for plotting found in ggplot2 (e.g. "point", +\item{geom}{type of geom to use for plotting found in ggplot2 (e.g. "point", "line", etc.). Default is "line". Other options are "point" and "area".} -\item{group}{a string of a single column that groups the data (e.g. "fleet", +\item{group}{a string of a single column that groups the data (e.g. "fleet", "sex", "area", etc.). Currently can only have one level of grouping.} -\item{facet}{a string or vector of strings of a column that facets the data +\item{facet}{a string or vector of strings of a column that facets the data (e.g. "year", "area", etc.)} \item{xlab}{a string of the x-axis label (default is "Year")} diff --git a/man/plot_indices.Rd b/man/plot_indices.Rd index 6fe42a8e..a4cb7b5f 100644 --- a/man/plot_indices.Rd +++ b/man/plot_indices.Rd @@ -67,6 +67,6 @@ Plot Index of Abundance plot_indices( dat = stockplotr:::example_data, unit_label = "fish/hr", - interactive = FALSE -) + interactive= FALSE) + } diff --git a/man/plot_recruitment.Rd b/man/plot_recruitment.Rd index 8c4828c3..0de81b6d 100644 --- a/man/plot_recruitment.Rd +++ b/man/plot_recruitment.Rd @@ -61,7 +61,7 @@ Default is the working directory.} } \value{ Plot recruitment over time from an assessment model output file -translated to a standardized output (\link[asar]{convert_output}). There are options to return a +translated to a standardized output (\link[stockplotr]{convert_output}). There are options to return a [ggplot2::ggplot()] object or export an rda object containing associated caption and alternative text for the figure. } diff --git a/man/plot_timeseries.Rd b/man/plot_timeseries.Rd index 2a5fb8b3..405ddf80 100644 --- a/man/plot_timeseries.Rd +++ b/man/plot_timeseries.Rd @@ -4,6 +4,18 @@ \alias{plot_timeseries} \title{Plot time series trends} \usage{ +plot_timeseries( + dat, + x = "year", + y = "estimate", + geom = "line", + xlab = "Year", + ylab = NULL, + group = NULL, + facet = NULL, + ... +) + plot_timeseries( dat, x = "year", @@ -47,9 +59,16 @@ Create a time series plot for a stock assessment report. The user has options to create a line, point, or area plot where the x-axis is year and Y can vary for any time series quantity. Currently, grouping is restricted to one group where faceting can be any number of facets. + +Create a time series plot for a stock assessment report. The user +has options to create a line, point, or area plot where the x-axis is year +and Y can vary for any time series quantity. Currently, grouping is +restricted to one group where faceting can be any number of facets. } \description{ Plot time series trends + +Create plot with error } \examples{ \dontrun{ @@ -63,4 +82,14 @@ plot_timeseries(dat, facet = "area" ) } +\dontrun{ +plot_timeseries(dat, + x = "year", + y = "estimate", + geom = "line", + xlab = "Year", + ylab = "Biomass", + group = "fleet", + facet = "area") +} } diff --git a/man/process_data.Rd b/man/process_data.Rd index 7c16c007..bd950c3b 100644 --- a/man/process_data.Rd +++ b/man/process_data.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/process_data.R \name{process_data} \alias{process_data} -\title{Post processing of filtered data} +\title{Processing for figures} \usage{ process_data(dat, group = NULL, facet = NULL, method = "sum") } @@ -33,7 +33,7 @@ variable(s) of the data. If NULL, no faceting variable is identified. Any identified indexed variables found in this function will be added to facet.} } \description{ -Post processing of filtered data +Processing for figures } \examples{ { diff --git a/man/process_table.Rd b/man/process_table.Rd new file mode 100644 index 00000000..8e9b31c1 --- /dev/null +++ b/man/process_table.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/process_data.R +\name{process_table} +\alias{process_table} +\title{Processing for tables} +\usage{ +process_table(dat, group = NULL, method = "sum", label = NULL) +} +\arguments{ +\item{dat}{Pre-filtered data from \link[stockplotr]{filter_data} following a +long format data.} + +\item{group}{A string identifying the indexing variable of the data. If you +want to just summarize the data across all factors, set group = "none".} + +\item{method}{A string describing the method of summarizing data when group +is set to "none". Options are "sum" or "mean". Default is "sum".} + +\item{label}{A string or vector of strings identifying the label values to filter the data.} +} +\value{ +A dataframe of processed data ready for formatting into a table. Input is an object created with \link[stockplotr]{filter_data}. +} +\description{ +Processing for tables +} +\examples{ +{ +filtered <- filter_data( +dat = stockplotr:::example_data, +label_name = "landings", +geom = "line", +era = "time" +) +process_table(dat = filtered, method = "sum") +} +} diff --git a/man/table_landings.Rd b/man/table_landings.Rd new file mode 100644 index 00000000..b7bdff21 --- /dev/null +++ b/man/table_landings.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/table_landings.R +\name{table_landings} +\alias{table_landings} +\title{Landed catch by fleet and year table} +\usage{ +table_landings( + dat, + unit_label = "mt", + era = NULL, + interactive = TRUE, + group = NULL, + method = "sum", + module = NULL, + label = NULL, + make_rda = FALSE, + tables_dir = getwd() +) +} +\arguments{ +\item{dat}{A data frame or names list of data frames (input as `list()`) +returned from \link[asar]{convert_output}. The first data frame in the list +is used in calculation of a reference line if one is present} + +\item{unit_label}{Abbreviated units of landings} + +\item{era}{a string naming the era of data such as historical ("early"), current ("time"), or +projected ("fore") data if filtering should occur. Default is set to "time" which is +the current time. To plot all data, set era to NULL.} + +\item{interactive}{TRUE/FALSE; indicate whether the environment in which the +function is operating is interactive. This bypasses some options for +filtering when preparing data for the plot. Default is FALSE.} + +\item{group}{A string identifying the indexing variable of the data. If you +want to just summarize the data across all factors, set group = "none".} + +\item{method}{A string describing the method of summarizing data when group +is set to "none". Options are "sum" or "mean". Default is "sum".} + +\item{module}{(Optional) A string indicating the linked module_name associated +with the label for the plot if known. Default is NULL. By default, the function +will select the most relevant module if more than 1 exists.} + +\item{label}{The label that will be chosen from the input file. If unspecified, +the function will search the "label" column and use the first matching label +in this ordered list: "landings_weight", "landings_numbers", "landings_expected", +"landings_predicted", "landings".} + +\item{make_rda}{TRUE/FALSE; indicate whether to produce an .rda file containing +a list with the figure/table, caption, and alternative text (if figure). If TRUE, +the rda will be exported to the folder indicated in the argument "figures_dir". +Default is FALSE.} + +\item{tables_dir}{The location of the folder containing the generated table +rda files ("tables") that will be created if the argument `make_rda` = TRUE.} +} +\value{ +Create a table ready for a stock assessment report of landed catch by +fleet and year. +} +\description{ +Landed catch by fleet and year table +} +\examples{ +table_landings(stockplotr::example_data) + +table_landings( + stockplotr::example_data, + unit_label = "landings label", + group = +) +} diff --git a/tests/testthat/test-save_all_plots.R b/tests/testthat/test-save_all_plots.R index 269a2b3d..d58814e2 100644 --- a/tests/testthat/test-save_all_plots.R +++ b/tests/testthat/test-save_all_plots.R @@ -23,21 +23,24 @@ test_that("save_all_plots works when all figures/tables are plotted", { # expect that the figures are all created with expected names fig_base_temp_files <- c( "biomass_figure.rda", + "CPUE.indices_figure.rda", + "fishing.mortality_figure.rda", + "landings_figure.rda", + "natural.mortality_figure.rda", "pop.baa_figure.rda", - # "catch_figure.rda", - # "landings_figure.rda", - "pop.caa_figure.rda", # not exporting in fxn for some reason + "pop.caa_figure.rda", "pop.naa_figure.rda", + "recruitment_figure.rda", "recruitment.deviations_figure.rda", - # "recruitment_figure.rda", # recruitment won't work when interactive = F bc first module doesn't contain any values - "spawning.biomass_figure.rda" + "spawning.biomass_figure.rda", + "sr_figure.rda" ) expect_equal( - list.files(fs::path(getwd(), "figures")), - fig_base_temp_files + sort(list.files(fs::path(getwd(), "figures"))), + sort(fig_base_temp_files) ) - # expect that the figures are all created with expected names + # expect that the tables are all created with expected names # tab_base_temp_files <- c( # "bnc_table.rda", # "indices.abundance_table.rda", @@ -53,52 +56,3 @@ test_that("save_all_plots works when all figures/tables are plotted", { unlink(fs::path(getwd(), "figures"), recursive = T) # unlink(fs::path(getwd(), "tables"), recursive = T) }) - -test_that("save_all_plots works when some figures/tables are not plotted", { - # plot all figs/tables except for plot_biomass - stockplotr::save_all_plots(out_new, - # add an unreal ref_line so plot_biomass doesn't work - ref_line = "not_a_real_ref_line", - ref_line_sb = "target", - # indices_unit_label = "CPUE", - figures_tables_dir = getwd(), - interactive = FALSE - ) - - # expect that the figures and tables dirs exist - expect_true(dir.exists(fs::path(getwd(), "figures"))) - # expect_true(dir.exists(fs::path(getwd(), "tables"))) - - # expect that the figures are all created with expected names - # except for biomass_figure - fig_base_temp_files <- c( - "biomass_figure.rda", - "pop.baa_figure.rda", - # "catch_figure.rda", - # "landings_figure.rda", - "pop.caa_figure.rda", # not exporting in fxn for some reason - "pop.naa_figure.rda", - "recruitment.deviations_figure.rda", - # "recruitment_figure.rda", # not working when not interactive bc first module doesn't contain any values - "spawning.biomass_figure.rda" - ) - expect_equal( - list.files(fs::path(getwd(), "figures")), - fig_base_temp_files - ) - - # expect that the figures are all created with expected names - # tab_base_temp_files <- c( - # "bnc_table.rda", - # "indices.abundance_table.rda", - # "landings_table.rda" - # ) - # expect_equal( - # list.files(fs::path(getwd(), "tables")), - # tab_base_temp_files - # ) - # erase temporary testing files - file.remove(fs::path(getwd(), "captions_alt_text.csv")) - unlink(fs::path(getwd(), "figures"), recursive = T) - # unlink(fs::path(getwd(), "tables"), recursive = T) -}) diff --git a/tests/testthat/test-table_landings.R b/tests/testthat/test-table_landings.R index 15b1ac12..86655d59 100644 --- a/tests/testthat/test-table_landings.R +++ b/tests/testthat/test-table_landings.R @@ -1,67 +1,81 @@ -# # load sample dataset -# load(file.path( -# "fixtures", "ss3_models_converted", "Hake_2018", -# "std_output.rda" -# )) +# load sample dataset +load(file.path( + "fixtures", "ss3_models_converted", "Hake_2018", + "std_output.rda" +)) -# test_that("table_landings generates plots without errors", { -# # expect error-free plot with minimal arguments -# expect_no_error( -# stockplotr::table_landings(out_new) -# ) +test_that("table_landings generates plots without errors", { + # expect error-free plot with minimal arguments + expect_no_error( + table_landings( + out_new, + interactive = FALSE, + module = "CATCH" + ) + ) -# # expect error-free plot with many arguments -# expect_no_error( -# stockplotr::table_landings( -# out_new, -# unit_label = "metric tons", -# end_year = 2024, -# make_rda = FALSE, -# tables_dir = getwd() -# ) -# ) + # expect error-free plot with many arguments + expect_no_error( + table_landings( + dat = out_new, + unit_label = "mt", + interactive = FALSE, + module = "CATCH", + make_rda = FALSE, + tables_dir = getwd() + ) + ) -# # expect flextable object is returned -# expect_s3_class( -# stockplotr::table_landings( -# out_new, -# unit_label = "metric tons", -# make_rda = FALSE, -# tables_dir = getwd() -# ), -# "flextable" -# ) -# }) + # expect gt object is returned + # adjust this test to work for multiple output tables + # expect_s3_class( + # table_landings( + # dat = out_new, + # unit_label = "mt", + # era = NULL, + # interactive = FALSE, + # module = "CATCH", + # make_rda = FALSE, + # tables_dir = getwd() + # ), + # "gt_tbl" + # ) +}) # test_that("rda file made when indicated", { # # export rda # table_landings( -# out_new, -# unit_label = "metric tons", -# end_year = 2024, +# dat = out_new, +# unit_label = "mt", +# era = NULL, +# interactive = FALSE, +# module = "CATCH", # make_rda = TRUE, # tables_dir = getwd() # ) - +# # # expect that both tables dir and the landings_table.rda file exist # expect_true(dir.exists(fs::path(getwd(), "tables"))) # expect_true(file.exists(fs::path(getwd(), "tables", "landings_table.rda"))) - +# # # erase temporary testing files # file.remove(fs::path(getwd(), "captions_alt_text.csv")) # unlink(fs::path(getwd(), "tables"), recursive = T) # }) -# test_that("table_landings generates error with future end_year", { -# # expect error -# expect_error( -# stockplotr::table_landings( -# out_new, -# unit_label = "metric tons", -# end_year = 2055, -# make_rda = FALSE, -# tables_dir = getwd() -# ) -# ) -# }) +test_that("table_landings generates error with incorrect module", { + # expect error + # Need to test this -- not exactly the right test/result + expect_error( + table_landings( + dat = out_new, + unit_label = "mt", + era = NULL, + interactive = FALSE, + module = "SPR_SERIES", + make_rda = FALSE, + tables_dir = getwd() + ) + ) +})