From 805e3ade61a5da5b63a04a86ee21356b42dc8f66 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Wed, 13 Aug 2025 16:45:43 -0400 Subject: [PATCH 01/62] change method of way lines are applied to rec devs --- NAMESPACE | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 3c4e849e..7a14191c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,5 +24,11 @@ export(plot_timeseries) export(process_data) export(reference_line) export(save_all_plots) +<<<<<<< HEAD +======= +export(table_bnc) +export(table_indices) +export(table_landings) +>>>>>>> 52625f7 (Apply viridis palette to figures (#135)) export(theme_noaa) export(write_captions) From d5577bbc1221dbb8b214d33621b8d755ec5527a6 Mon Sep 17 00:00:00 2001 From: Sophie Breitbart Date: Wed, 20 Aug 2025 08:58:08 -0400 Subject: [PATCH 02/62] Apply viridis palette to figures (#135) * remove exp_all_figs_tables() and add theme_noaa() to exports * Update theme_noaa() to apply viridis palette to figures; update documentation --- NAMESPACE | 6 ------ 1 file changed, 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 7a14191c..3c4e849e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,11 +24,5 @@ export(plot_timeseries) export(process_data) export(reference_line) export(save_all_plots) -<<<<<<< HEAD -======= -export(table_bnc) -export(table_indices) -export(table_landings) ->>>>>>> 52625f7 (Apply viridis palette to figures (#135)) export(theme_noaa) export(write_captions) From 73d71fce16d116e13be466e4975f00faed218cb2 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Thu, 11 Sep 2025 09:26:47 -0400 Subject: [PATCH 03/62] Revamped sr, aa plots, recruitment ts, and more (#130) * add module as argument so user can remove the menu option when it is known * update sr documentation and add argument * Revamped N-at-age plot (#131) * add baseline timeseries plot and adjustments to plot_rec_devs * update function and fix bugs when only one dat is present * move rda out of plot function and add as separate fxn * move rda making functions into single file for organization * minor change to naa plot for testing before dev, lay plot_aa function foundation for other at age plots * add and update plot_aa * adjust plot_abundanc_at_age with revamped, modular design * gsub space for _ when present in faceting and fix error in code * add stop if no data was extracted from the df * select N module - always the first option in output atm * feature to add facet of model when more than one output results are provided * allow filtered data to also be scaled by adding argument * add arg for scaling abundance * adjust how reference line is implemented and make changes to revamped plots that use it * revert new setup of refernce line - can not do list trick, but still make fixes to sb plot * revamp biomass at age plot and update documentation * adjust aa plot so avg age line is added as a component instead of in base * update plot_catch_comps for revamp and follow same type of plot from r4ss * minor adjustments to catch comp, calculate circles are area proportional to catch * add option to turn proportional on/off * add in missing avg age line from baa plot * fix bug where b should have been catch in catch comp plot * fix leftover rebase and re-document * fix missing legend and adjust scales. Add in missing 'proportional' argument to functions * more fixes to legend and testing * update documentation * fix NAA documentation to change group to facet * add commas into legend labels * comment out y limits for now - removing the -1 messes with the y_n_breaks functioning and adds axis ticks on the half * change group to facet in aa args * update all aa plot documentation * Fix key quantity names for NAA so that start/end years are successfully added to alt text * add CAA key quantity calculations to write_captions() * Update R/plot_catch_comp.R Co-authored-by: Sophie Breitbart * update figure labels and add in caption and figure for caa plot * update NAA test * add new tests to naa to test proportional arg * update biomass_at_age plot tests and fix issue in extracting biomass * update catch comp tests * Update inst/resources/captions_alt_text_template.csv Co-authored-by: Sophie Breitbart * Edited utils_rda.R so that tot.catch.min and max are rounded and subbed into the alt text csv * change cohort line to black and fix error message in catch_comp plot * update stop in catch_comp and update alt text * remove aes(color = model) from plot_aa() * add new key quantities for alt text and update them in export * fix bug in calculating avg age line; update examples in revelant aa plots; update documentation: --------- Co-authored-by: sbreitbart-NOAA * fix documentation and replace missing code from old rebases and reverting code * update spawn rec plot and associated functions back to working * add new function to calc magnitude of the label on y axis usually * add option for legend so the units get wrapped or not * update plots that use magnitude labelling method * Update "How captions and alternative text are generated" vignette to match new workflow * fix relative and scale_amount arg implementation into spawning_biomass * add back in rda utils, update sb plot and tests, update documentation * adjust sr plot tests and fix per one test * adjust test and fxn for rec devs * adjust output rda for spawn recruit fxn * update documentation and comment out tests that need updating but aren't part of this PR * fix export_rda -- change back to object instead of final * fix tests and comment out those for fxns that aren't yet modified * additional fixes to functions * minor changes to remove some warnings from checks * fix prep data error is properly incorporated into rec devs plot * Revamped b plot (#136) * add URL and BugReports links to DESCRIPTION, the only non-outdated changes from https://github.com/nmfs-ost/stockplotr/pull/86#issuecomment-3212161587 * add empty line to end of DESCRIPTION * Update documentation * Update required R version in DESCRIPTION * Update plot_biomass() params, function, documentation * Update plot_biomass test so that it tests when relative = TRUE * change interative default to TRUE --------- Co-authored-by: Schiano-NOAA * Revamped recruitment plot (#137) * Update plot_recruitment() fxn, documentation, and test * Address spellcheck; update documentation; add module_name example in plot_recruitment() * remove or keep hline in plot_error depending on the plot; replace primary plotting function in plot_recruitment * Make plot_recruitment() line thicker * Update documentation --------- Co-authored-by: Schiano-NOAA * add option to filter by era in the case that some models don't have it or the user wants to plot all eras, this change also adds lines at points where eras change; this is added into all relevant functions * adjust sr plot to add commas where needed and adjust plot_timeries to add commas to y-axis, also add scale_amount as arg in sr and removed era * fix sr plot where bam was not working if naming not the same. Also remove commans to x-axis from tseries general fxn to sr plot specific * fix reference line label when era is not time * update key quantities for sr * increase descriptiveness of return and standardizes across functions * fix catch comp plot to plot landings for BAM conout --------- Co-authored-by: sbreitbart-NOAA --- R/plot_biomass.R | 3 +- R/plot_recruitment.R | 2 +- R/plot_spawning_biomass.R | 1 + R/utils_plot.R | 182 ++++++++++++++++++++++++- man/plot_error.Rd | 2 +- man/plot_timeseries.Rd | 31 +++++ tests/testthat/test-plot_recruitment.R | 1 + 7 files changed, 217 insertions(+), 5 deletions(-) diff --git a/R/plot_biomass.R b/R/plot_biomass.R index c75f6798..d0c83bf0 100644 --- a/R/plot_biomass.R +++ b/R/plot_biomass.R @@ -78,10 +78,9 @@ plot_biomass <- function( # Filter data for spawning biomass prepared_data <- filter_data( dat = dat, - label_name = "^biomass$|^biomass_retained$|^biomass_dead$", + label_name = "^biomass", geom = geom, group = group, - facet = facet, module = module, scale_amount = scale_amount, interactive = interactive diff --git a/R/plot_recruitment.R b/R/plot_recruitment.R index 29a0f190..0c097753 100644 --- a/R/plot_recruitment.R +++ b/R/plot_recruitment.R @@ -146,7 +146,7 @@ plot_recruitment <- function( if (make_rda) { create_rda( object = final, - topic_label = caption_label, + topic_label = "recruitment", fig_or_table = "figure", dat = dat, dir = figures_dir # , diff --git a/R/plot_spawning_biomass.R b/R/plot_spawning_biomass.R index 878610e8..d96288cc 100644 --- a/R/plot_spawning_biomass.R +++ b/R/plot_spawning_biomass.R @@ -98,6 +98,7 @@ plot_spawning_biomass <- function( label = "Spawning Biomass", unit_label = unit_label, scale_amount = scale_amount, + legend = TRUE ) } diff --git a/R/utils_plot.R b/R/utils_plot.R index 5242aef0..c8181c64 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -203,6 +203,187 @@ plot_timeseries <- function( #' @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_line( + data = dat, + ggplot2::aes( + .data[[x]], + .data[[y]], + linetype = group_var, + # linetype = ifelse(!is.null(group), .data[[group]], "solid") + color = model + ), + linewidth = 1.0, + ... + ) + + 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 + ) + }, + "area" = { + plot + + ggplot2::geom_area( + data = dat, + ggplot2::aes( + .data[[x]], + .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) + breaks <- ggplot2::scale_x_continuous( + n.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 horizantal line at 1 +#' @param ... inherited arguments from internal functions from ggplot2::geom_xx +#' +#' plot_error <- function( dat, x = "year", @@ -832,7 +1013,6 @@ filter_data <- function( model = reorder(.data[["model"]], .data[["estimate"]], function(x) -max(x)) ) } - plot_data } diff --git a/man/plot_error.Rd b/man/plot_error.Rd index d34bb491..eb0f9cd9 100644 --- a/man/plot_error.Rd +++ b/man/plot_error.Rd @@ -41,7 +41,7 @@ is "estimate")} \item{ylab}{a string of the y-axis label. If NULL, it will be set to the name of `y`.} -\item{hline}{indicate true or false to place a horizontal line at 1} +\item{hline}{indicate true or false to place a horizantal line at 1} \item{...}{inherited arguments from internal functions from ggplot2::geom_xx} } diff --git a/man/plot_timeseries.Rd b/man/plot_timeseries.Rd index 2a5fb8b3..b7e734a1 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", @@ -41,15 +53,24 @@ of `y`.} (e.g. "year", "area", etc.)} \item{...}{inherited arguments from internal functions from ggplot2::geom_xx} + +\item{hline}{indicate true or false to place a horizontal line at 1} } \value{ 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 +84,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/tests/testthat/test-plot_recruitment.R b/tests/testthat/test-plot_recruitment.R index 2a46dd14..40bd9832 100644 --- a/tests/testthat/test-plot_recruitment.R +++ b/tests/testthat/test-plot_recruitment.R @@ -48,6 +48,7 @@ test_that("plot_recruitment generates plots without errors", { scale_amount = 10, # relative = TRUE, module = "TIME_SERIES", + relative = T, make_rda = FALSE, figures_dir = getwd() ), From fb0c48c882d19c5a7aa2949ab04fac09eb478dd4 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Thu, 11 Sep 2025 09:39:16 -0400 Subject: [PATCH 04/62] fix spelling errors --- R/utils_plot.R | 2 +- man/plot_error.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils_plot.R b/R/utils_plot.R index c8181c64..41bd9a34 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -380,7 +380,7 @@ 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 horizantal line at 1 +#' @param hline indicate true or false to place a horizontal line at 1 #' @param ... inherited arguments from internal functions from ggplot2::geom_xx #' #' diff --git a/man/plot_error.Rd b/man/plot_error.Rd index eb0f9cd9..d34bb491 100644 --- a/man/plot_error.Rd +++ b/man/plot_error.Rd @@ -41,7 +41,7 @@ is "estimate")} \item{ylab}{a string of the y-axis label. If NULL, it will be set to the name of `y`.} -\item{hline}{indicate true or false to place a horizantal line at 1} +\item{hline}{indicate true or false to place a horizontal line at 1} \item{...}{inherited arguments from internal functions from ggplot2::geom_xx} } From e3481a081ec8724d31af14a2e12ded0a9d083228 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Mon, 15 Sep 2025 15:49:28 -0400 Subject: [PATCH 05/62] change x_n_breaks function to instead work with scales::pretty_breaks to better fit axes for all functions --- R/utils_plot.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils_plot.R b/R/utils_plot.R index 41bd9a34..286da388 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -334,7 +334,7 @@ plot_timeseries <- function( # Calc axis breaks x_n_breaks <- axis_breaks(dat) breaks <- ggplot2::scale_x_continuous( - n.breaks = x_n_breaks, + breaks = x_n_breaks, guide = ggplot2::guide_axis( minor.ticks = TRUE ) From ae1d2170df01fad590d3f9e73e41b7393fca390b Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Mon, 15 Sep 2025 16:02:37 -0400 Subject: [PATCH 06/62] adjust caption and alt text depending on what the graph is showing if predicted recruitment is present --- R/plot_recruitment.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plot_recruitment.R b/R/plot_recruitment.R index 0c097753..29a0f190 100644 --- a/R/plot_recruitment.R +++ b/R/plot_recruitment.R @@ -146,7 +146,7 @@ plot_recruitment <- function( if (make_rda) { create_rda( object = final, - topic_label = "recruitment", + topic_label = caption_label, fig_or_table = "figure", dat = dat, dir = figures_dir # , From de33bb05e5f4a3686083239e8f014f7148620038 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Tue, 16 Sep 2025 14:34:56 -0400 Subject: [PATCH 07/62] open geom options for plots; adjust text size in theme; move error cloud under line plot --- R/plot_spawning_biomass.R | 1 - R/utils_plot.R | 24 ++++++++++++------------ 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/R/plot_spawning_biomass.R b/R/plot_spawning_biomass.R index d96288cc..878610e8 100644 --- a/R/plot_spawning_biomass.R +++ b/R/plot_spawning_biomass.R @@ -98,7 +98,6 @@ plot_spawning_biomass <- function( label = "Spawning Biomass", unit_label = unit_label, scale_amount = scale_amount, - legend = TRUE ) } diff --git a/R/utils_plot.R b/R/utils_plot.R index 286da388..2baf6e17 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -262,7 +262,17 @@ plot_timeseries <- function( ) }, "line" = { - plot + + 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( @@ -272,18 +282,8 @@ plot_timeseries <- function( # linetype = ifelse(!is.null(group), .data[[group]], "solid") color = model ), - linewidth = 1.0, + # linewidth = 1.0, ... - ) + - 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 ) }, "area" = { From f09a58a00c83613d97a2729d0ad5076646dab4ec Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Wed, 17 Sep 2025 15:12:51 -0400 Subject: [PATCH 08/62] replace axis_breaks to use pretty breaks in scales package and set ref line as subscript in annotation in ggplot2::annotate for reference line label --- R/utils_plot.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils_plot.R b/R/utils_plot.R index 2baf6e17..3657f5d4 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -332,7 +332,7 @@ plot_timeseries <- function( } # Calc axis breaks - x_n_breaks <- axis_breaks(dat) + x_n_breaks <- axis_breaks(dat[[x]]) breaks <- ggplot2::scale_x_continuous( breaks = x_n_breaks, guide = ggplot2::guide_axis( From b21f012bf2111664e15265af7437d4b679682060 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Wed, 17 Sep 2025 16:01:08 -0400 Subject: [PATCH 09/62] fix issue with biomass plot where if group or facet is used (or not used) then any extra occurrances in the data are included resulting in an incorrect plot --- R/plot_biomass.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plot_biomass.R b/R/plot_biomass.R index d0c83bf0..a0f5f3ea 100644 --- a/R/plot_biomass.R +++ b/R/plot_biomass.R @@ -78,7 +78,7 @@ plot_biomass <- function( # Filter data for spawning biomass prepared_data <- filter_data( dat = dat, - label_name = "^biomass", + label_name = "^biomass$", geom = geom, group = group, module = module, From 30810ad0531ea9df4198275b4fe812da3b731af3 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Wed, 17 Sep 2025 17:06:19 -0400 Subject: [PATCH 10/62] adjust to all instead of all_of for check. Setting now so plot does not fail when the group doesn't exist --- R/plot_spawning_biomass.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/plot_spawning_biomass.R b/R/plot_spawning_biomass.R index 878610e8..c02e8c3f 100644 --- a/R/plot_spawning_biomass.R +++ b/R/plot_spawning_biomass.R @@ -166,8 +166,8 @@ plot_spawning_biomass <- function( geom = geom, ylab = spawning_biomass_label, group = group, - facet = facet, - ... + facet = facet#, + # ... ) # Add reference line # getting data set - an ifelse statement in the fxn wasn't working From ee2ed66cb07db8ea3cdbf6bc0ab6565995d414b2 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Thu, 18 Sep 2025 15:51:16 -0400 Subject: [PATCH 11/62] fix error with biomass plot and grouping/faceting variables --- R/plot_biomass.R | 1 + R/plot_spawning_biomass.R | 4 ++-- R/utils_plot.R | 6 +++--- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/R/plot_biomass.R b/R/plot_biomass.R index a0f5f3ea..d3645799 100644 --- a/R/plot_biomass.R +++ b/R/plot_biomass.R @@ -81,6 +81,7 @@ plot_biomass <- function( label_name = "^biomass$", geom = geom, group = group, + facet = facet, module = module, scale_amount = scale_amount, interactive = interactive diff --git a/R/plot_spawning_biomass.R b/R/plot_spawning_biomass.R index c02e8c3f..878610e8 100644 --- a/R/plot_spawning_biomass.R +++ b/R/plot_spawning_biomass.R @@ -166,8 +166,8 @@ plot_spawning_biomass <- function( geom = geom, ylab = spawning_biomass_label, group = group, - facet = facet#, - # ... + facet = facet, + ... ) # Add reference line # getting data set - an ifelse statement in the fxn wasn't working diff --git a/R/utils_plot.R b/R/utils_plot.R index 3657f5d4..184d88c6 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -279,7 +279,7 @@ plot_timeseries <- function( .data[[x]], .data[[y]], linetype = group_var, - # linetype = ifelse(!is.null(group), .data[[group]], "solid") + # linetype = ifelse(!is.null(group), group_var, "solid"), color = model ), # linewidth = 1.0, @@ -291,8 +291,8 @@ plot_timeseries <- function( ggplot2::geom_area( data = dat, ggplot2::aes( - .data[[x]], - .data[[y]], + x = .data[[x]], + y = .data[[y]], fill = model ), ... From 1e32763c6eedd79b718db6a4c2b7968a43566b64 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Fri, 19 Sep 2025 11:38:53 -0400 Subject: [PATCH 12/62] update prepare_data to summarize data even when group is selected in the case there is only one group and the data gets repeated --- R/utils_plot.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/utils_plot.R b/R/utils_plot.R index 184d88c6..395b3658 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -1013,6 +1013,7 @@ filter_data <- function( model = reorder(.data[["model"]], .data[["estimate"]], function(x) -max(x)) ) } + plot_data } From be9dc858401dd5a031cfdeaefe2b4f2b62e7e603 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Fri, 19 Sep 2025 11:39:41 -0400 Subject: [PATCH 13/62] update plot_biomass to summarize ret, sel, and dead biomass from ss3 models when it's present --- R/plot_biomass.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plot_biomass.R b/R/plot_biomass.R index d3645799..c75f6798 100644 --- a/R/plot_biomass.R +++ b/R/plot_biomass.R @@ -78,7 +78,7 @@ plot_biomass <- function( # Filter data for spawning biomass prepared_data <- filter_data( dat = dat, - label_name = "^biomass$", + label_name = "^biomass$|^biomass_retained$|^biomass_dead$", geom = geom, group = group, facet = facet, From a4c038ecd75bc9b256949c2641e90ae64e4b1703 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Tue, 23 Sep 2025 17:10:31 -0400 Subject: [PATCH 14/62] update save_all_plots and work on tests --- R/save_all_plots.R | 73 +++++++++++++++++++++++----------------------- 1 file changed, 37 insertions(+), 36 deletions(-) diff --git a/R/save_all_plots.R b/R/save_all_plots.R index a820370f..69c6e855 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_spawn_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_spawn_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") From a8f86e70119521752f35965c3c1bbd6e4485ad33 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Thu, 25 Sep 2025 11:35:34 -0400 Subject: [PATCH 15/62] update documentation; remove non-revamped plots and tables for release to package; fix tests and comment out unused tests --- R/save_all_plots.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/save_all_plots.R b/R/save_all_plots.R index 69c6e855..977d2867 100644 --- a/R/save_all_plots.R +++ b/R/save_all_plots.R @@ -69,7 +69,7 @@ save_all_plots <- function( ref_line = "msy", biomass_scale_amount = 1, # imported from plot_landings - # landings_unit_label = "mt", + landings_unit_label = "mt", # imported from plot_recruitment_deviations- zero unique arguments # imported from plot_spawn_recruitment spawning_biomass_label = "mt", @@ -83,7 +83,7 @@ save_all_plots <- function( biomass_at_age_scale_amount = 1, biomass_at_age_unit_label = "mt", # imported from plot_indices - # indices_unit_label = "", + indices_unit_label = "", # imported from table_afsc_tier- add potential unique arguments after dev # imported from table_bnc biomass_unit_label = "mt", From 438c92989d7e692dadf47a68b9ca13ffb8e0aa48 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Fri, 3 Oct 2025 16:01:39 -0400 Subject: [PATCH 16/62] updates to plot_landings and adjustment to utils --- R/plot_landings.R | 1 + 1 file changed, 1 insertion(+) 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 + } From 393fcddc3e90cc83fa6bec7cfc9c9a98c9f795c3 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Fri, 10 Oct 2025 15:50:33 -0400 Subject: [PATCH 17/62] update documentation --- man/plot_timeseries.Rd | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/man/plot_timeseries.Rd b/man/plot_timeseries.Rd index b7e734a1..2a5fb8b3 100644 --- a/man/plot_timeseries.Rd +++ b/man/plot_timeseries.Rd @@ -4,18 +4,6 @@ \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", @@ -53,24 +41,15 @@ of `y`.} (e.g. "year", "area", etc.)} \item{...}{inherited arguments from internal functions from ggplot2::geom_xx} - -\item{hline}{indicate true or false to place a horizontal line at 1} } \value{ 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{ @@ -84,14 +63,4 @@ plot_timeseries(dat, facet = "area" ) } -\dontrun{ -plot_timeseries(dat, - x = "year", - y = "estimate", - geom = "line", - xlab = "Year", - ylab = "Biomass", - group = "fleet", - facet = "area") -} } From 4ae885a1cf4a8f46630c49b1dd8fceb3aafe6fd5 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Tue, 14 Oct 2025 12:47:35 -0400 Subject: [PATCH 18/62] update stockplotr tests --- tests/testthat/test-plot_recruitment.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-plot_recruitment.R b/tests/testthat/test-plot_recruitment.R index 40bd9832..2a46dd14 100644 --- a/tests/testthat/test-plot_recruitment.R +++ b/tests/testthat/test-plot_recruitment.R @@ -48,7 +48,6 @@ test_that("plot_recruitment generates plots without errors", { scale_amount = 10, # relative = TRUE, module = "TIME_SERIES", - relative = T, make_rda = FALSE, figures_dir = getwd() ), From 7d1ac26dfe70659da52f9e77445f9abf6b9ee77d Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Fri, 17 Oct 2025 12:38:12 -0400 Subject: [PATCH 19/62] minor changes so fxn works with bam and incorporate && in if statements --- R/plot_natural_mortality.R | 1 - R/process_data.R | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) 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/process_data.R b/R/process_data.R index e20afbfd..a225ae50 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -317,6 +317,7 @@ process_data <- function( group <- NULL } } + # Export list of objects list( # variable, From b06d1b00316009bafe49f7c30846819df9203be2 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Wed, 22 Oct 2025 16:28:50 -0400 Subject: [PATCH 20/62] fix error in using wrong df in process_data fxn --- R/process_data.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/process_data.R b/R/process_data.R index a225ae50..ee509c5e 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -117,6 +117,7 @@ process_data <- function( } else { data <- dat } + if (length(index_variables) > 0) { data <- data |> dplyr::select(tidyselect::all_of(c( @@ -138,6 +139,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)] From f01ea9c1d906a7ca368a9b50aa3daf6aeaaa73fa Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Wed, 5 Nov 2025 15:39:46 -0500 Subject: [PATCH 21/62] Add process_data to plots (#153) * update process data for a more general process and apply to sb plot * add process data as an export to package * add process_data to biomass * make updates to process_data and add new filtering to biomass plot * fix issue where explicit group was not prioritized and filter biomass to better suit workflow * fix final errors when setting grouping in different ways * fix check in plots for faceting * cleanup plot_biomass and process_data * add process data to NAA plot * add process data to other fxns * fix issue with process data when group is none and add new arg * fix process_data due to conflicting steps since summ happens with group=none * fix issue where when group is null but has an indexing with 1 uniquw value it still plots a legend * update process_data in plot M * minor tweak to process data and fix refernce in fxns * fix plot_land with process_data * add process data to landings and recruitment * update documentation * fix errors from devtools check and fix rec devs fxn with new process_data * fix a couple more issues * fix example in landings plot * adjust fxn title and description * change size to linewidth arg in rec plot * add check before removing age from variables * minor documentation update: --- R/plot_biomass_at_age.R | 1 + R/plot_catch_comp.R | 9 +++++++++ R/process_data.R | 1 + 3 files changed, 11 insertions(+) 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_catch_comp.R b/R/plot_catch_comp.R index 675b1463..e67e8627 100644 --- a/R/plot_catch_comp.R +++ b/R/plot_catch_comp.R @@ -73,6 +73,15 @@ plot_catch_comp <- function( interactive = interactive, module = module ) + # Process data to recognize grouping and faceting variables + processed_data <- process_data( + dat = catch, + group = "age", + facet = facet + ) + data <- processed_data[[1]] + group <- processed_data[[3]] + facet <- processed_data[[2]] # Check for extracted data, if not return warning and empty plot if (nrow(catch) == 0) { cli::cli_alert_warning("No data found for catch at age. Please check the input data.") diff --git a/R/process_data.R b/R/process_data.R index ee509c5e..57b4da30 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -62,6 +62,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? From d5ba43ac27634e560e8d6c7c1a559b6e2abeb2a8 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 14 Nov 2025 11:43:37 -0500 Subject: [PATCH 22/62] Hotfix revamped plots round 2 (#154) * add documentation for group=none into time series plots where applicable and add to process data. Remove from filter_data * add if else statement to add plots to set facet = none to summarize data * update documentation of facet to reflect new option * fix issue with missing package and catch comp error --- R/plot_catch_comp.R | 9 --------- 1 file changed, 9 deletions(-) diff --git a/R/plot_catch_comp.R b/R/plot_catch_comp.R index e67e8627..675b1463 100644 --- a/R/plot_catch_comp.R +++ b/R/plot_catch_comp.R @@ -73,15 +73,6 @@ plot_catch_comp <- function( interactive = interactive, module = module ) - # Process data to recognize grouping and faceting variables - processed_data <- process_data( - dat = catch, - group = "age", - facet = facet - ) - data <- processed_data[[1]] - group <- processed_data[[3]] - facet <- processed_data[[2]] # Check for extracted data, if not return warning and empty plot if (nrow(catch) == 0) { cli::cli_alert_warning("No data found for catch at age. Please check the input data.") From 3cbf929e03d3f8400b8b04ec97cf8ace6b49ea56 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Thu, 6 Nov 2025 10:39:59 -0500 Subject: [PATCH 23/62] create new utils file and uncomment landings tbl --- R/table_landings.R | 414 ++++++++++++++++++++++----------------------- R/utils_table.R | 4 + 2 files changed, 211 insertions(+), 207 deletions(-) create mode 100644 R/utils_table.R diff --git a/R/table_landings.R b/R/table_landings.R index 599debe0..acd61e79 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -1,207 +1,207 @@ -# #' 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 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 +} diff --git a/R/utils_table.R b/R/utils_table.R new file mode 100644 index 00000000..7757b54e --- /dev/null +++ b/R/utils_table.R @@ -0,0 +1,4 @@ +############################## +# Utility functions for tables +############################## + From e1dd78980fb9b2948cdf2400b842a0c00a93e4d6 Mon Sep 17 00:00:00 2001 From: Schiano-NOAA Date: Thu, 6 Nov 2025 16:48:59 -0500 Subject: [PATCH 24/62] add foundation of making latex table --- R/utils_table.R | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/R/utils_table.R b/R/utils_table.R index 7757b54e..352f2889 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -2,3 +2,33 @@ # Utility functions for tables ############################## +create_table <- function(data) { + ncols <- ncol(data) + column_names <- paste(colnames(data), collapse = " & ") + latex_format_data <- paste( + column_names, "\n" + ) + for (i in 1:nrow(data)) { + row_data <- stringr::str_replace_all( + paste(data[i,], collapse = " & "), + "NA", + "-") + latex_format_data <- paste( + latex_format_data, + row_data, "\n", + sep = "", + collapse = "\n" + ) + } + + table <- paste0( + "\\begin{document}\n", + "\\begin{tabular}{lr}\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, + "\\end{tabular}\n", + collapse = "\n" + ) +} \ No newline at end of file From fc026feea2a236e0d9c304e80d1b21b1f53d4ea5 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 19 Nov 2025 17:22:49 -0500 Subject: [PATCH 25/62] Update create_table() to fix bugs producing latex-based table from data frame --- R/utils_table.R | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/R/utils_table.R b/R/utils_table.R index 352f2889..e2b47c31 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -6,26 +6,35 @@ create_table <- function(data) { ncols <- ncol(data) column_names <- paste(colnames(data), collapse = " & ") latex_format_data <- paste( - column_names, "\n" + 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, - row_data, "\n", + row_data_with_linebreak, "\n", + # row_data, "\n", sep = "", collapse = "\n" ) } table <- paste0( - "\\begin{document}\n", - "\\begin{tabular}{lr}\n", + # "\\begin{document}\n", + "\\begin{tabular}{", alignment, "}\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 + "\\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, "\\end{tabular}\n", From 3dcb75febf1fe5ae98e655b1d51e2157ecddd07b Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 20 Nov 2025 11:38:52 -0500 Subject: [PATCH 26/62] Update name of latex table-producing function (create_latex_table), arguments, code, and documentation --- DESCRIPTION | 2 +- NAMESPACE | 2 + R/utils_table.R | 130 +++++++++++++++++++++++++++----------- man/create_latex_table.Rd | 28 ++++++++ 4 files changed, 125 insertions(+), 37 deletions(-) create mode 100644 man/create_latex_table.Rd diff --git a/DESCRIPTION b/DESCRIPTION index fe447551..a444fc22 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -44,6 +44,7 @@ Imports: gt, httr, kableExtra, + knitr, naniar, prodlim, quarto, @@ -56,7 +57,6 @@ Imports: withr Suggests: here, - knitr, rmarkdown, testthat (>= 3.0.0) VignetteBuilder: diff --git a/NAMESPACE b/NAMESPACE index 3c4e849e..570673b3 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) @@ -24,5 +25,6 @@ export(plot_timeseries) export(process_data) export(reference_line) export(save_all_plots) +export(table_landings) export(theme_noaa) export(write_captions) diff --git a/R/utils_table.R b/R/utils_table.R index e2b47c31..f8f3df00 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -2,42 +2,100 @@ # Utility functions for tables ############################## -create_table <- function(data) { - ncols <- ncol(data) - column_names <- paste(colnames(data), collapse = " & ") - latex_format_data <- paste( - column_names, "\\\\", "\n" - ) +#' 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) { - # c signifies all cols will be centered - alignment <- strrep("c", ncols) + # Essential latex packages: + # \usepackage{hyperref} + # \usepackage{bookmark} + # \usepackage{booktabs} + # \usepackage{tagpdf} + # \usepackage{caption} - 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, - row_data_with_linebreak, "\n", - # row_data, "\n", - sep = "", - collapse = "\n" - ) - } + latex_tbl <- knitr::kable(data, + format = "latex", + booktabs = TRUE, + linesep = "") - table <- paste0( - # "\\begin{document}\n", - "\\begin{tabular}{", alignment, "}\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, - "\\end{tabular}\n", - collapse = "\n" - ) -} \ No newline at end of file + # 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, + "\n", + lab, + "\n", + latex_tbl, + "\n", + "\\end{center}") + + # 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" + # ) + # + cat(table) +} 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" +) +} From 699fe164384c4b4677f5a72cf8533df7e306dfb3 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 20 Nov 2025 15:16:34 -0500 Subject: [PATCH 27/62] Update export_rda() to be able to intake a latex table as an arg; update table_landings() to create a latex-based table and add it to the rda; update documentation --- R/table_landings.R | 224 ++++++++++++++++++++++-------------------- R/utils_rda.R | 10 +- R/utils_table.R | 4 +- man/export_rda.Rd | 8 +- man/table_landings.Rd | 50 ++++++++++ 5 files changed, 181 insertions(+), 115 deletions(-) create mode 100644 man/table_landings.Rd diff --git a/R/table_landings.R b/R/table_landings.R index acd61e79..a7f9891f 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -45,114 +45,116 @@ table_landings <- function(dat, 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) + # # 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" # } - - 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 - )) - + # + # # 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 + # )) + + land <- head(dat) + # add theming to final table final <- land |> flextable::flextable() |> @@ -193,13 +195,19 @@ table_landings <- function(dat, fig_or_table = fig_or_table, dir = tables_dir ) + + # create LaTeX-based table + latex_table <- create_latex_table(data = land, + caption = caps_alttext[1], + label = "landings_latex") export_rda( object = final, caps_alttext = caps_alttext, figures_tables_dir = tables_dir, topic_label = topic_label, - fig_or_table = fig_or_table + fig_or_table = fig_or_table, + latex_table = latex_table ) } # Return finished table diff --git a/R/utils_rda.R b/R/utils_rda.R index e693e7fc..84a2ec75 100644 --- a/R/utils_rda.R +++ b/R/utils_rda.R @@ -1821,6 +1821,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 +1835,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 +1851,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 +1872,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 index f8f3df00..c17880f3 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -54,6 +54,8 @@ create_latex_table <- function(data, "\n", "\\end{center}") + table + # ncols <- ncol(data) # column_names <- paste(colnames(data), collapse = " & ") # latex_format_data <- paste( @@ -96,6 +98,4 @@ create_latex_table <- function(data, # "\\end{tabular}\n", # collapse = "\n" # ) - # - cat(table) } 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/table_landings.Rd b/man/table_landings.Rd new file mode 100644 index 00000000..83620607 --- /dev/null +++ b/man/table_landings.Rd @@ -0,0 +1,50 @@ +% 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", + end_year = format(Sys.Date(), "\%Y"), + make_rda = FALSE, + tables_dir = getwd() +) +} +\arguments{ +\item{dat}{A data frame or names list of data frames 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{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. +Default is the working directory.} +} +\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{ +\dontrun{ +table_landings(dat) + +table_landings( + dat, + unit_label = "landings label", + end_year = 2024, + make_rda = TRUE, + tables_dir = getwd() +) +} +} From cea30beb48b1a170b189e4cc598f27e628e35eb2 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 20 Nov 2025 15:18:02 -0500 Subject: [PATCH 28/62] Uncomment code in table_landings() that creates a table (though it's not working as expected) --- R/table_landings.R | 214 ++++++++++++++++++++++----------------------- 1 file changed, 106 insertions(+), 108 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index a7f9891f..9ef79ff3 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -45,115 +45,113 @@ table_landings <- function(dat, 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) + # 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) # } - # - # # 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 - # )) - - land <- head(dat) + + 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 |> From fa98f347a6953a5b76381a23d246145f5473b7b5 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 20 Nov 2025 16:46:16 -0500 Subject: [PATCH 29/62] Remove extra line breaks from latex tables --- R/utils_table.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/utils_table.R b/R/utils_table.R index c17880f3..7629df78 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -47,9 +47,7 @@ create_latex_table <- function(data, "\n", "\\begin{center}\n", cap, - "\n", lab, - "\n", latex_tbl, "\n", "\\end{center}") From d4811e287325ec47c3ad9fb6e879eeb55be643d1 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Fri, 5 Dec 2025 11:05:28 -0500 Subject: [PATCH 30/62] Start setting up table_landings() for filter_data()/process_data() workflow --- R/table_landings.R | 215 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 207 insertions(+), 8 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index 9ef79ff3..3bce017a 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -27,23 +27,222 @@ table_landings <- function(dat, 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 ) + + # filter_data <- function( + # dat, + # label_name, + # module = NULL, + # era = "time", + # geom, + # group = NULL, + # facet = NULL, + # scale_amount = 1, + # interactive = TRUE) { + + # read standard data file and extract target quantity + prepared_data <- dat |> + dplyr::filter( + c(module_name == "TIME_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) + + + + + + + + + + + + # # 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 + # } 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], NA), + # estimate = as.numeric(estimate) / scale_amount, + # # 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 + # ) + # ) + # # 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 |> + # dplyr::mutate( + # group_var = switch(geom, + # "line" = "solid", + # "point" = "black", + # 1 + # ) + # ) + # # Set group to NULL if second condition is met + # group = NULL + # } else { + # data <- data |> + # dplyr::mutate( + # group_var = .data[[group]] + # ) + # } + # list_of_data[[get_id(dat)[i]]] <- data + # } + # # Put in + # plot_data <- dplyr::bind_rows(list_of_data, .id = "model") + # # do.call(rbind, list_of_data) + # + # # Check if there are multiple module_names present + # if (length(unique(plot_data$module_name)) > 1) { + # if (!is.null(module)) { + # plot_data <- plot_data |> + # dplyr::filter( + # module_name %in% module + # ) + # } else { + # cli::cli_alert_warning("Multiple module names found in data. \n") + # options <- c() + # for (i in seq_along(unique(plot_data$module_name))) { + # # options <- paste0(options, " ", i, ") ", unique(plot_data$module_name)[i], "\n") + # options[i] <- paste0(unique(plot_data$module_name)[i]) + # } + # if (interactive()) { + # if(interactive) { + # # question1 <- utils::menu( + # # options, + # # title = "Please select one of the following:" + # # ) + # question1 <- utils::select.list( + # options, + # multiple = TRUE, + # title = "Select one or more of the following module names" + # ) + # # selected_module <- unique(plot_data$module_name)[as.numeric(question1)] + # selected_module <- intersect( + # unique(plot_data$module_name), + # question1 + # ) + # } else { + # selected_module <- unique(plot_data$module_name)[1] + # cli::cli_alert_info("Selection bypassed. Filtering by {selected_module}.") + # } + # } else { + # selected_module <- unique(plot_data$module_name)[1] + # cli::cli_alert_info(glue::glue("Environment not interactive. Selecting {selected_module}.")) + # } + # if (length(selected_module) > 0) { + # plot_data <- plot_data |> + # dplyr::filter( + # module_name %in% selected_module + # ) + # } + # } + # } + # } + # + + + + + + + + + + + # TODO: add an option to stratify by gear type + + # Units + land_label <- glue::glue("Landings ({unit_label})") # read standard data file and extract target quantity land_dat <- dat |> @@ -94,7 +293,7 @@ table_landings <- function(dat, } 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.) From 896f328343e3d72f1f668ea5492f97147c94ef27 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 11 Dec 2025 11:11:34 -0500 Subject: [PATCH 31/62] Continue developing landings table, and basic workflow needed for all tables --- R/process_data.R | 73 ++++++++- R/table_landings.R | 361 ++++++--------------------------------------- R/utils_plot.R | 2 +- 3 files changed, 116 insertions(+), 320 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 57b4da30..60714f8d 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. @@ -329,3 +333,70 @@ process_data <- function( facet ) } + + + +#' Processing for tables +#' +#' @inheritParams process_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 = dat, +#' label_name = "landings", +#' geom = "line", +#' era = "time" +#' ) +#' process_table(dat = filtered, method = "sum") +#' } +process_table <- function( + dat, + group = NULL, + method = "sum"){ + + index_variables <- check_grouping(dat) + + #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}).") + } + } + + id_group <- index_variables[-grepl("year|age|length_bin", index_variables)] + cols <- index_variables[grepl("year|age|length_bin", index_variables)] + + table_data <- dat |> + dplyr::select(dplyr::all_of(c( + "label", "model", index_variables, "estimate", "uncertainty_label", "uncertainty" + ))) |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c(cols)), + values_from = dplyr::all_of(c("estimate", "uncertainty")), + names_from = dplyr::all_of(c("label", "uncertainty_label", "model", id_group))) + + table_data +} diff --git a/R/table_landings.R b/R/table_landings.R index 3bce017a..33360530 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -24,7 +24,10 @@ #' } table_landings <- function(dat, unit_label = "mt", - end_year = format(Sys.Date(), "%Y"), + era = "time", + interactive = TRUE, + module = NULL, + scale_amount = 1, make_rda = FALSE, tables_dir = getwd()) { @@ -34,334 +37,56 @@ table_landings <- function(dat, # 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 + #TODO: add these args to the table_landings() args + # Filter data for landings + prepared_data <- filter_data( + dat = dat, + label_name = "landings", + geom = "line", + era = era, + # group = ifelse(length(group) > 1, group[1], group), + # facet = ifelse(length(group) > 1, group[-1], NULL), + module = module, + scale_amount = scale_amount, + interactive = interactive ) - # filter_data <- function( - # dat, - # label_name, - # module = NULL, - # era = "time", - # geom, - # group = NULL, - # facet = NULL, - # scale_amount = 1, - # interactive = TRUE) { + #TODO: add check for if length of label > 1 (if TRUE, then a specific value (e.g., observed?) will need to be selected) - # read standard data file and extract target quantity - prepared_data <- dat |> - dplyr::filter( - c(module_name == "TIME_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) + # add a check for which landings-related name to extract (e.g., expected, observed, cv...) + table_data <- process_table( + dat = prepared_data, + group = group, + method = method) + # put table_data into a nice table (kable) + # ensure cols in order: estimate, error, est, error, etc. + # try to keep it to one column + capitalized_names <- c(year = "Year", + sex = "Sex", + fleet = "Fleet", + model = "Model") - - - - - - - - - # # 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 - # } 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], NA), - # estimate = as.numeric(estimate) / scale_amount, - # # 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 - # ) - # ) - # # 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 |> - # dplyr::mutate( - # group_var = switch(geom, - # "line" = "solid", - # "point" = "black", - # 1 - # ) - # ) - # # Set group to NULL if second condition is met - # group = NULL - # } else { - # data <- data |> - # dplyr::mutate( - # group_var = .data[[group]] - # ) - # } - # list_of_data[[get_id(dat)[i]]] <- data - # } - # # Put in - # plot_data <- dplyr::bind_rows(list_of_data, .id = "model") - # # do.call(rbind, list_of_data) - # - # # Check if there are multiple module_names present - # if (length(unique(plot_data$module_name)) > 1) { - # if (!is.null(module)) { - # plot_data <- plot_data |> - # dplyr::filter( - # module_name %in% module - # ) - # } else { - # cli::cli_alert_warning("Multiple module names found in data. \n") - # options <- c() - # for (i in seq_along(unique(plot_data$module_name))) { - # # options <- paste0(options, " ", i, ") ", unique(plot_data$module_name)[i], "\n") - # options[i] <- paste0(unique(plot_data$module_name)[i]) - # } - # if (interactive()) { - # if(interactive) { - # # question1 <- utils::menu( - # # options, - # # title = "Please select one of the following:" - # # ) - # question1 <- utils::select.list( - # options, - # multiple = TRUE, - # title = "Select one or more of the following module names" - # ) - # # selected_module <- unique(plot_data$module_name)[as.numeric(question1)] - # selected_module <- intersect( - # unique(plot_data$module_name), - # question1 - # ) - # } else { - # selected_module <- unique(plot_data$module_name)[1] - # cli::cli_alert_info("Selection bypassed. Filtering by {selected_module}.") - # } - # } else { - # selected_module <- unique(plot_data$module_name)[1] - # cli::cli_alert_info(glue::glue("Environment not interactive. Selecting {selected_module}.")) - # } - # if (length(selected_module) > 0) { - # plot_data <- plot_data |> - # dplyr::filter( - # module_name %in% selected_module - # ) - # } - # } - # } - # } - # - - - - - - - - - - - # TODO: add an option to stratify by gear type - - # Units - land_label <- glue::glue("Landings ({unit_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" - } + final <- table_data |> + dplyr::rename(dplyr::any_of(capitalized_names)) |> + dplyr::rename_with(~ gsub("_NA|_label|estimate_", "", .)) #|> + kableExtra::kable(format = "latex") # 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 - )) + # 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 diff --git a/R/utils_plot.R b/R/utils_plot.R index 395b3658..c98edd55 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -1131,7 +1131,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() From 3394a1698ee34e4cfb80a1790896f60056ebac7a Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 11 Dec 2025 15:58:14 -0500 Subject: [PATCH 32/62] Finish first draft of landings table; update documentation --- NAMESPACE | 1 + R/table_landings.R | 68 ++++++++++++++++++++++++++++--------------- man/process_data.Rd | 4 +-- man/process_table.Rd | 35 ++++++++++++++++++++++ man/table_landings.Rd | 33 +++++++++++++++++---- 5 files changed, 109 insertions(+), 32 deletions(-) create mode 100644 man/process_table.Rd diff --git a/NAMESPACE b/NAMESPACE index 570673b3..ec1158a4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ export(plot_spawn_recruitment) export(plot_spawning_biomass) export(plot_timeseries) export(process_data) +export(process_table) export(reference_line) export(save_all_plots) export(table_landings) diff --git a/R/table_landings.R b/R/table_landings.R index 33360530..ebf2ddab 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -3,8 +3,8 @@ #' @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. +#' 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. @@ -28,6 +28,7 @@ table_landings <- function(dat, interactive = TRUE, module = NULL, scale_amount = 1, + label = "landings_weight", make_rda = FALSE, tables_dir = getwd()) { @@ -51,41 +52,60 @@ table_landings <- function(dat, interactive = interactive ) + # order potential labels by applicability + ordered_labels <- c("landings_weight", + "landings_numbers", + "landings_expected", + "landings_predicted", + "landings") + + # Choose label to filter by, based on presence in prepared_data + for (lab in ordered_labels) { + if (lab %in% prepared_data$label) { + target_label <- lab + break + } + } + prepared_data2 <- prepared_data |> + dplyr::filter(label == target_label) + #TODO: add check for if length of label > 1 (if TRUE, then a specific value (e.g., observed?) will need to be selected) # add a check for which landings-related name to extract (e.g., expected, observed, cv...) table_data <- process_table( - dat = prepared_data, + dat = prepared_data2, group = group, method = method) - # put table_data into a nice table (kable) + # put table_data into a nice table # ensure cols in order: estimate, error, est, error, etc. # try to keep it to one column - capitalized_names <- c(year = "Year", - sex = "Sex", - fleet = "Fleet", - model = "Model") + capitalized_names <- c("Year" = "year", + "Sex" = "sex", + "Fleet" = "fleet", + "Model" = "model") - final <- table_data |> - dplyr::rename(dplyr::any_of(capitalized_names)) |> - dplyr::rename_with(~ gsub("_NA|_label|estimate_", "", .)) #|> - kableExtra::kable(format = "latex") + landings_colname <- paste0("Landings (", unit_label, ")") + + #TODO: Update add_theme() for gt tables + final_df <- table_data |> + dplyr::rename(dplyr::any_of(capitalized_names)) |> + dplyr::rename_with(~ gsub("_NA|_label|estimate_", "", .)) |> + dplyr::rename(dplyr::any_of(stats::setNames(target_label, landings_colname))) |> + dplyr::rename_with(~ gsub(target_label, "", .)) |> + dplyr::rename_with(~ gsub("^uncertainty_$", "Uncertainty", .)) + + final <- final_df |> + gt::gt() + # Progress: + # for bsb, hake, vsnap, and stockplotr::example_data, cols are: + # "Year", "Landings ()", "Uncertainty" + + # TODO: Reorder column names so that numeric fleets show up in chronological # order (currently, lists 1, 10, 11, 12, etc.) - - # land <- land |> - # dplyr::select(order(colnames(land), - # method = "auto" - # )) |> - # dplyr::relocate(Year, .before = 1) |> - # dplyr::rename_with(~ stringr::str_replace( - # ., - # "Landings", - # land_label - # )) # export figure to rda if argument = T if (make_rda == TRUE) { @@ -119,7 +139,7 @@ table_landings <- function(dat, ) # create LaTeX-based table - latex_table <- create_latex_table(data = land, + latex_table <- create_latex_table(data = final_df, caption = caps_alttext[1], label = "landings_latex") 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..29c91879 --- /dev/null +++ b/man/process_table.Rd @@ -0,0 +1,35 @@ +% 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") +} +\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".} +} +\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 = dat, +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 index 83620607..07cfbb9d 100644 --- a/man/table_landings.Rd +++ b/man/table_landings.Rd @@ -7,26 +7,47 @@ table_landings( dat, unit_label = "mt", - end_year = format(Sys.Date(), "\%Y"), + era = "time", + interactive = TRUE, + module = NULL, + scale_amount = 1, + label = "landings_weight", make_rda = FALSE, tables_dir = getwd() ) } \arguments{ -\item{dat}{A data frame or names list of data frames 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{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{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{scale_amount}{A number describing how much to scale down the quantities +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{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. -Default is the working directory.} +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 From 3b39d6c3c3f9516099a960734147776fce52e2bb Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Thu, 11 Dec 2025 16:08:56 -0500 Subject: [PATCH 33/62] Update documentation --- R/plot_indices.R | 6 +++--- man/plot_error.Rd | 2 +- man/plot_indices.Rd | 3 +-- man/plot_timeseries.Rd | 31 +++++++++++++++++++++++++++++++ 4 files changed, 36 insertions(+), 6 deletions(-) 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/man/plot_error.Rd b/man/plot_error.Rd index d34bb491..c028d37e 100644 --- a/man/plot_error.Rd +++ b/man/plot_error.Rd @@ -19,7 +19,7 @@ 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 is "year")} diff --git a/man/plot_indices.Rd b/man/plot_indices.Rd index 6fe42a8e..43036c5c 100644 --- a/man/plot_indices.Rd +++ b/man/plot_indices.Rd @@ -67,6 +67,5 @@ Plot Index of Abundance plot_indices( dat = stockplotr:::example_data, unit_label = "fish/hr", - interactive = FALSE -) + interactive= FALSE) } diff --git a/man/plot_timeseries.Rd b/man/plot_timeseries.Rd index 2a5fb8b3..b7e734a1 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", @@ -41,15 +53,24 @@ of `y`.} (e.g. "year", "area", etc.)} \item{...}{inherited arguments from internal functions from ggplot2::geom_xx} + +\item{hline}{indicate true or false to place a horizontal line at 1} } \value{ 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 +84,14 @@ plot_timeseries(dat, facet = "area" ) } +\dontrun{ +plot_timeseries(dat, + x = "year", + y = "estimate", + geom = "line", + xlab = "Year", + ylab = "Biomass", + group = "fleet", + facet = "area") +} } From 8bbe5754876dcd88dbe9ca12c68f6feaa8abbb45 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Tue, 16 Dec 2025 17:41:55 -0500 Subject: [PATCH 34/62] Develop plot_landings() further to work for bam and ss3 data --- R/table_landings.R | 105 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 81 insertions(+), 24 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index ebf2ddab..6bbf6eb3 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -28,7 +28,7 @@ table_landings <- function(dat, interactive = TRUE, module = NULL, scale_amount = 1, - label = "landings_weight", + label = NULL, make_rda = FALSE, tables_dir = getwd()) { @@ -52,6 +52,10 @@ table_landings <- function(dat, interactive = interactive ) + + #TODO: add check for if length of label > 1 (if TRUE, then a specific value (e.g., observed?) will need to be selected) + + # order potential labels by applicability ordered_labels <- c("landings_weight", "landings_numbers", @@ -59,28 +63,45 @@ table_landings <- function(dat, "landings_predicted", "landings") - # Choose label to filter by, based on presence in prepared_data - for (lab in ordered_labels) { - if (lab %in% prepared_data$label) { - target_label <- lab - break + if (is.null(label)){ + cli::cli_alert_info("`label` not specified.") + # Choose label to filter by, based on presence in prepared_data + for (lab in ordered_labels) { + if (lab %in% prepared_data$label) { + target_label <- lab + break + } } + cli::cli_alert_info("`label` selected as {target_label}.") + } else { + target_label <- label } + prepared_data2 <- prepared_data |> dplyr::filter(label == target_label) - #TODO: add check for if length of label > 1 (if TRUE, then a specific value (e.g., observed?) will need to be selected) - - # add a check for which landings-related name to extract (e.g., expected, observed, cv...) + # get uncertainty label + uncert_lab <- prepared_data2$uncertainty_label |> + unique() + + if (length(uncert_lab) > 1){ + 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.") + } + # get fleet names + fleets <- prepared_data2$fleet |> + unique() |> + sort() + table_data <- process_table( - dat = prepared_data2, - group = group, - method = method) + dat = prepared_data2#, + # group = group, + # method = method + ) # put table_data into a nice table - # ensure cols in order: estimate, error, est, error, etc. - # try to keep it to one column capitalized_names <- c("Year" = "year", "Sex" = "sex", "Fleet" = "fleet", @@ -90,22 +111,58 @@ table_landings <- function(dat, #TODO: Update add_theme() for gt tables final_df <- table_data |> - dplyr::rename(dplyr::any_of(capitalized_names)) |> - dplyr::rename_with(~ gsub("_NA|_label|estimate_", "", .)) |> - dplyr::rename(dplyr::any_of(stats::setNames(target_label, landings_colname))) |> - dplyr::rename_with(~ gsub(target_label, "", .)) |> - dplyr::rename_with(~ gsub("^uncertainty_$", "Uncertainty", .)) + dplyr::rename(dplyr::any_of(capitalized_names)) |> + dplyr::rename_with(~ gsub(target_label, "", .)) |> + dplyr::rename_with( + .fn = ~ paste0(landings_colname, "_", stringr::str_extract(., "[^_]+$")), + .cols = contains("estimate")) |> + dplyr::rename_with(~ gsub("_NA|_label", "", .)) |> + dplyr::rename_with( + # replace an underscore only if it's at the end of the colname + .fn = ~ stringr::str_replace(., pattern = "_$", replacement = ""), + .cols = everything() + ) |> + dplyr::rename_with(~ gsub("uncertainty_", "", .)) |> + dplyr::rename_with(~ gsub("_", " - ", .)) |> + dplyr::rename_with( + .fn = ~ stringr::str_replace(., + pattern = "^ - ", + replacement = ""), + .cols = everything() + ) + + # dplyr::rename_with(~ gsub("__", "_", .)) |> + + + # Order columns by landings / cv / landings, etc. and with alphabetical fleets + if (length(fleets) > 0){ + cols_to_sort <- final_df |> + dplyr::select(-Year) |> + colnames() + fleet_codes <- stringr::str_extract(cols_to_sort, "(?<=- )[^ ]+") + order_index <- order(fleet_codes, + cols_to_sort, + decreasing = c(FALSE, FALSE), + method = "radix") + ordered_cols_to_sort <- cols_to_sort[order_index] + final_df <- final_df |> + dplyr::select( + Year, + dplyr::all_of(ordered_cols_to_sort) + ) + } final <- final_df |> gt::gt() - + final # Progress: # for bsb, hake, vsnap, and stockplotr::example_data, cols are: - # "Year", "Landings ()", "Uncertainty" - + # "Year", "Landings ()", "uncertainty" + # for am, cols are: + # "Landings (mt) - cbn", "cv - cbn", "Landings (mt) - cbs", "cv - cbs", etc - # TODO: Reorder column names so that numeric fleets show up in chronological - # order (currently, lists 1, 10, 11, 12, etc.) + # TODO: Check that numeric fleets show up in chronological + # order (currently, may list 1, 10, 11, 12, etc.) # export figure to rda if argument = T if (make_rda == TRUE) { From 8b3dd497f4fce2e2bebb16c3b46d897ff41d53db Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 11:32:15 -0500 Subject: [PATCH 35/62] Fix save_all_plots except for fishing.mortality plot --- R/save_all_plots.R | 403 ++++++++++++++++----------- tests/testthat/test-save_all_plots.R | 14 +- 2 files changed, 243 insertions(+), 174 deletions(-) diff --git a/R/save_all_plots.R b/R/save_all_plots.R index 977d2867..cf4c57c7 100644 --- a/R/save_all_plots.R +++ b/R/save_all_plots.R @@ -99,66 +99,68 @@ save_all_plots <- function( # figures - tryCatch( - { - cli::cli_h2("plot_recruitment") - plot_recruitment( - dat, - unit_label = recruitment_unit_label, - scale_amount = recruitment_scale_amount, - interactive = interactive, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) #|> - # suppressWarnings() |> - # invisible() - }, - error = function(e) { - cli::cli_alert_danger("plot_recruitment failed to run.") - cli::cli_alert("Tip: check that your arguments are correct.") - cli::cli_li("recruitment_unit_label = {recruitment_unit_label}") - cli::cli_li("recruitment_scale_amount = {recruitment_scale_amount}") - cli::cli_li("relative = {relative}") - print(e) - } - ) - - - tryCatch( - { - cli::cli_h2("plot_biomass") - plot_biomass( - dat, - unit_label = biomass_unit_label, - scale_amount = biomass_scale_amount, - ref_line = ref_line, - relative = relative, - interactive = interactive, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) #|> - # suppressWarnings() |> - # invisible() - }, - error = function(e) { - cli::cli_alert_danger("plot_biomass failed to run.") - cli::cli_alert("Tip: check that your arguments are correct.") - cli::cli_li("biomass_unit_label = {biomass_unit_label}") - cli::cli_li("biomass_scale_amount = {biomass_scale_amount}") - cli::cli_li("ref_line = {ref_line}") - cli::cli_li("relative = {relative}") - print(e) - } - ) - - + # tryCatch( + # { + # cli::cli_h2("plot_recruitment") + # plot_recruitment( + # dat, + # unit_label = recruitment_unit_label, + # scale_amount = recruitment_scale_amount, + # interactive = FALSE, + # module = "TIME_SERIES", + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) #|> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # cli::cli_alert_danger("plot_recruitment failed to run.") + # cli::cli_alert("Tip: check that your arguments are correct.") + # cli::cli_li("recruitment_unit_label = {recruitment_unit_label}") + # cli::cli_li("recruitment_scale_amount = {recruitment_scale_amount}") + # cli::cli_li("relative = {relative}") + # print(e) + # } + # ) + # + # + # tryCatch( + # { + # cli::cli_h2("plot_biomass") + # plot_biomass( + # dat, + # unit_label = biomass_unit_label, + # scale_amount = biomass_scale_amount, + # ref_line = ref_line, + # relative = relative, + # interactive = interactive, + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) #|> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # cli::cli_alert_danger("plot_biomass failed to run.") + # cli::cli_alert("Tip: check that your arguments are correct.") + # cli::cli_li("biomass_unit_label = {biomass_unit_label}") + # cli::cli_li("biomass_scale_amount = {biomass_scale_amount}") + # cli::cli_li("ref_line = {ref_line}") + # cli::cli_li("relative = {relative}") + # print(e) + # } + # ) + # + # # tryCatch( # { # cli::cli_h2("plot_landings") # plot_landings(dat, # unit_label = landings_unit_label, - # make_rda, - # figures_dir = figures_tables_dir + # make_rda = TRUE, + # figures_dir = figures_tables_dir, + # interactive = FALSE # ) # |> # # suppressWarnings() |> # # invisible() @@ -173,127 +175,194 @@ save_all_plots <- function( tryCatch( { - cli::cli_h2("plot_recruitment_deviations") - plot_recruitment_deviations( - dat, - interactive = interactive, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) #|> + 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_recruitment_deviations failed to run.") + cli::cli_alert_danger("plot_fishing_mortality failed to run.") cli::cli_alert("Tip: check that your arguments are correct.") - print(e) - } - ) - - # plot_spawn_recruitment(dat, - # spawning_biomass_label, - # recruitment_label = recruitment_unit_label, - # make_rda, - # figures_dir = figures_tables_dir)# |> suppressWarnings() |> invisible() - - tryCatch( - { - cli::cli_h2("plot_spawning_biomass") - plot_spawning_biomass( - dat, - unit_label = spawning_biomass_label, - scale_amount = spawning_biomass_scale_amount, - ref_line = ref_line_sb, - relative = relative, - interactive = interactive, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) # |> - # suppressWarnings() |> - # invisible() - }, - error = function(e) { - cli::cli_alert_danger("plot_spawning_biomass 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("spawning_biomass_scale_amount = {spawning_biomass_scale_amount}") - cli::cli_li("ref_line_sb = {ref_line_sb}") cli::cli_li("relative = {relative}") print(e) } ) - tryCatch( - { - cli::cli_h2("plot_abundance_at_age") - plot_abundance_at_age( - dat, - unit_label = abundance_at_age_unit_label, - scale_amount = abundance_at_age_scale_amount, - proportional = proportional, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) # |> - # suppressWarnings() |> - # invisible() - }, - error = function(e) { - cli::cli_alert_danger("plot_abundance_at_age failed to run.") - cli::cli_alert("Tip: check that your arguments are correct.") - cli::cli_li("abundance_at_age_unit_label = {abundance_at_age_unit_label}") - cli::cli_li("abundance_at_age_scale_amount = {abundance_at_age_scale_amount}") - print(e) - } - ) - - tryCatch( - { - plot_catch_comp( - dat, - unit_label = catch_unit_label, - scale_amount = catch_scale_amount, - proportional = proportional, - interactive = interactive, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) # |> - # suppressWarnings() |> - # invisible() - }, - error = function(e) { - message("plot_catch_comp failed to run. Tip: check that your arguments are correct.") - 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_biomass_at_age") - plot_biomass_at_age( - dat, - unit_label = biomass_at_age_unit_label, - scale_amount = biomass_at_age_scale_amount, - proportional = proportional, - make_rda = TRUE, - figures_dir = figures_tables_dir - ) # |> - # suppressWarnings() |> - # invisible() - }, - error = function(e) { - 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_recruitment_deviations") + # plot_recruitment_deviations( + # dat, + # interactive = FALSE, + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) #|> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # cli::cli_alert_danger("plot_recruitment_deviations failed to run.") + # cli::cli_alert("Tip: check that your arguments are correct.") + # print(e) + # } + # ) + # + # tryCatch( + # { + # cli::cli_h2("plot_spawn_recruitment") + # plot_spawn_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_spawn_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( + # { + # cli::cli_h2("plot_spawning_biomass") + # plot_spawning_biomass( + # dat, + # unit_label = spawning_biomass_label, + # scale_amount = spawning_biomass_scale_amount, + # ref_line = ref_line_sb, + # relative = relative, + # interactive = interactive, + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) # |> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # cli::cli_alert_danger("plot_spawning_biomass 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("spawning_biomass_scale_amount = {spawning_biomass_scale_amount}") + # cli::cli_li("ref_line_sb = {ref_line_sb}") + # cli::cli_li("relative = {relative}") + # print(e) + # } + # ) + # + # tryCatch( + # { + # cli::cli_h2("plot_abundance_at_age") + # plot_abundance_at_age( + # dat, + # unit_label = abundance_at_age_unit_label, + # scale_amount = abundance_at_age_scale_amount, + # proportional = proportional, + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) # |> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # cli::cli_alert_danger("plot_abundance_at_age failed to run.") + # cli::cli_alert("Tip: check that your arguments are correct.") + # cli::cli_li("abundance_at_age_unit_label = {abundance_at_age_unit_label}") + # cli::cli_li("abundance_at_age_scale_amount = {abundance_at_age_scale_amount}") + # print(e) + # } + # ) + # + # tryCatch( + # { + # plot_catch_comp( + # dat, + # unit_label = catch_unit_label, + # scale_amount = catch_scale_amount, + # proportional = proportional, + # interactive = FALSE, + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) # |> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # 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) + # } + # ) + # + # tryCatch( + # { + # cli::cli_h2("plot_biomass_at_age") + # plot_biomass_at_age( + # dat, + # unit_label = biomass_at_age_unit_label, + # scale_amount = biomass_at_age_scale_amount, + # proportional = proportional, + # make_rda = TRUE, + # figures_dir = figures_tables_dir + # ) # |> + # # suppressWarnings() |> + # # invisible() + # }, + # error = function(e) { + # 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) + # } + # ) - # uncomment when this is working properly - # plot_indices(dat, - # unit_label = indices_unit_label, - # make_rda, - # figures_dir = figures_tables_dir)# |> suppressWarnings() |> invisible() + # 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("indices_unit_label = {indices_unit_label}") + # print(e) + # } + # ) # tables # tryCatch( @@ -304,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() |> @@ -325,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() |> @@ -343,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/tests/testthat/test-save_all_plots.R b/tests/testthat/test-save_all_plots.R index 269a2b3d..5b45fc75 100644 --- a/tests/testthat/test-save_all_plots.R +++ b/tests/testthat/test-save_all_plots.R @@ -24,12 +24,12 @@ test_that("save_all_plots works when all figures/tables are plotted", { fig_base_temp_files <- c( "biomass_figure.rda", "pop.baa_figure.rda", - # "catch_figure.rda", - # "landings_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", # recruitment won't work when interactive = F bc first module doesn't contain any values + "recruitment_figure.rda", "spawning.biomass_figure.rda" ) expect_equal( @@ -74,12 +74,12 @@ test_that("save_all_plots works when some figures/tables are not plotted", { 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 + "catch_figure.rda", + "landings_figure.rda", + "pop.caa_figure.rda", "pop.naa_figure.rda", "recruitment.deviations_figure.rda", - # "recruitment_figure.rda", # not working when not interactive bc first module doesn't contain any values + "recruitment_figure.rda", "spawning.biomass_figure.rda" ) expect_equal( From d72e0d68149781e679695f3e8796420c70037b95 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 12:08:07 -0500 Subject: [PATCH 36/62] Uncomment code that exports all figures in save_all_plots(); comment out code causing issues related to missing alt text for fishing mortality plot --- R/save_all_plots.R | 484 ++++++++++++++++++++++----------------------- R/utils_rda.R | 76 +++---- 2 files changed, 281 insertions(+), 279 deletions(-) diff --git a/R/save_all_plots.R b/R/save_all_plots.R index cf4c57c7..93b208f1 100644 --- a/R/save_all_plots.R +++ b/R/save_all_plots.R @@ -99,79 +99,79 @@ save_all_plots <- function( # figures - # tryCatch( - # { - # cli::cli_h2("plot_recruitment") - # plot_recruitment( - # dat, - # unit_label = recruitment_unit_label, - # scale_amount = recruitment_scale_amount, - # interactive = FALSE, - # module = "TIME_SERIES", - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) #|> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # cli::cli_alert_danger("plot_recruitment failed to run.") - # cli::cli_alert("Tip: check that your arguments are correct.") - # cli::cli_li("recruitment_unit_label = {recruitment_unit_label}") - # cli::cli_li("recruitment_scale_amount = {recruitment_scale_amount}") - # cli::cli_li("relative = {relative}") - # print(e) - # } - # ) - # - # - # tryCatch( - # { - # cli::cli_h2("plot_biomass") - # plot_biomass( - # dat, - # unit_label = biomass_unit_label, - # scale_amount = biomass_scale_amount, - # ref_line = ref_line, - # relative = relative, - # interactive = interactive, - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) #|> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # cli::cli_alert_danger("plot_biomass failed to run.") - # cli::cli_alert("Tip: check that your arguments are correct.") - # cli::cli_li("biomass_unit_label = {biomass_unit_label}") - # cli::cli_li("biomass_scale_amount = {biomass_scale_amount}") - # cli::cli_li("ref_line = {ref_line}") - # cli::cli_li("relative = {relative}") - # 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_recruitment") + plot_recruitment( + dat, + unit_label = recruitment_unit_label, + scale_amount = recruitment_scale_amount, + interactive = FALSE, + module = "TIME_SERIES", + make_rda = TRUE, + figures_dir = figures_tables_dir + ) #|> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_recruitment failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("recruitment_unit_label = {recruitment_unit_label}") + cli::cli_li("recruitment_scale_amount = {recruitment_scale_amount}") + cli::cli_li("relative = {relative}") + print(e) + } + ) + + + tryCatch( + { + cli::cli_h2("plot_biomass") + plot_biomass( + dat, + unit_label = biomass_unit_label, + scale_amount = biomass_scale_amount, + ref_line = ref_line, + relative = relative, + interactive = interactive, + make_rda = TRUE, + figures_dir = figures_tables_dir + ) #|> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_biomass failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("biomass_unit_label = {biomass_unit_label}") + cli::cli_li("biomass_scale_amount = {biomass_scale_amount}") + cli::cli_li("ref_line = {ref_line}") + cli::cli_li("relative = {relative}") + 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( { @@ -192,177 +192,177 @@ save_all_plots <- function( } ) - # 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_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 = FALSE, - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) #|> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # cli::cli_alert_danger("plot_recruitment_deviations failed to run.") - # cli::cli_alert("Tip: check that your arguments are correct.") - # print(e) - # } - # ) - # - # tryCatch( - # { - # cli::cli_h2("plot_spawn_recruitment") - # plot_spawn_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_spawn_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( - # { - # cli::cli_h2("plot_spawning_biomass") - # plot_spawning_biomass( - # dat, - # unit_label = spawning_biomass_label, - # scale_amount = spawning_biomass_scale_amount, - # ref_line = ref_line_sb, - # relative = relative, - # interactive = interactive, - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) # |> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # cli::cli_alert_danger("plot_spawning_biomass 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("spawning_biomass_scale_amount = {spawning_biomass_scale_amount}") - # cli::cli_li("ref_line_sb = {ref_line_sb}") - # cli::cli_li("relative = {relative}") - # print(e) - # } - # ) - # - # tryCatch( - # { - # cli::cli_h2("plot_abundance_at_age") - # plot_abundance_at_age( - # dat, - # unit_label = abundance_at_age_unit_label, - # scale_amount = abundance_at_age_scale_amount, - # proportional = proportional, - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) # |> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # cli::cli_alert_danger("plot_abundance_at_age failed to run.") - # cli::cli_alert("Tip: check that your arguments are correct.") - # cli::cli_li("abundance_at_age_unit_label = {abundance_at_age_unit_label}") - # cli::cli_li("abundance_at_age_scale_amount = {abundance_at_age_scale_amount}") - # print(e) - # } - # ) - # - # tryCatch( - # { - # plot_catch_comp( - # dat, - # unit_label = catch_unit_label, - # scale_amount = catch_scale_amount, - # proportional = proportional, - # interactive = FALSE, - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) # |> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # 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) - # } - # ) - # - # tryCatch( - # { - # cli::cli_h2("plot_biomass_at_age") - # plot_biomass_at_age( - # dat, - # unit_label = biomass_at_age_unit_label, - # scale_amount = biomass_at_age_scale_amount, - # proportional = proportional, - # make_rda = TRUE, - # figures_dir = figures_tables_dir - # ) # |> - # # suppressWarnings() |> - # # invisible() - # }, - # error = function(e) { - # 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_recruitment_deviations") + plot_recruitment_deviations( + dat, + interactive = FALSE, + make_rda = TRUE, + figures_dir = figures_tables_dir + ) #|> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_recruitment_deviations failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + 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("indices_unit_label = {indices_unit_label}") - # print(e) - # } - # ) + tryCatch( + { + cli::cli_h2("plot_spawn_recruitment") + plot_spawn_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_spawn_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( + { + cli::cli_h2("plot_spawning_biomass") + plot_spawning_biomass( + dat, + unit_label = spawning_biomass_label, + scale_amount = spawning_biomass_scale_amount, + ref_line = ref_line_sb, + relative = relative, + interactive = interactive, + make_rda = TRUE, + figures_dir = figures_tables_dir + ) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_spawning_biomass 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("spawning_biomass_scale_amount = {spawning_biomass_scale_amount}") + cli::cli_li("ref_line_sb = {ref_line_sb}") + cli::cli_li("relative = {relative}") + print(e) + } + ) + + tryCatch( + { + cli::cli_h2("plot_abundance_at_age") + plot_abundance_at_age( + dat, + unit_label = abundance_at_age_unit_label, + scale_amount = abundance_at_age_scale_amount, + proportional = proportional, + make_rda = TRUE, + figures_dir = figures_tables_dir + ) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + cli::cli_alert_danger("plot_abundance_at_age failed to run.") + cli::cli_alert("Tip: check that your arguments are correct.") + cli::cli_li("abundance_at_age_unit_label = {abundance_at_age_unit_label}") + cli::cli_li("abundance_at_age_scale_amount = {abundance_at_age_scale_amount}") + print(e) + } + ) + + tryCatch( + { + plot_catch_comp( + dat, + unit_label = catch_unit_label, + scale_amount = catch_scale_amount, + proportional = proportional, + interactive = FALSE, + make_rda = TRUE, + figures_dir = figures_tables_dir + ) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + 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) + } + ) + + tryCatch( + { + cli::cli_h2("plot_biomass_at_age") + plot_biomass_at_age( + dat, + unit_label = biomass_at_age_unit_label, + scale_amount = biomass_at_age_scale_amount, + proportional = proportional, + make_rda = TRUE, + figures_dir = figures_tables_dir + ) # |> + # suppressWarnings() |> + # invisible() + }, + error = function(e) { + 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("indices_unit_label = {indices_unit_label}") + print(e) + } + ) # tables # tryCatch( diff --git a/R/utils_rda.R b/R/utils_rda.R index 84a2ec75..b95f66ad 100644 --- a/R/utils_rda.R +++ b/R/utils_rda.R @@ -115,6 +115,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 +139,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 From 816267ff718c022f6351504a48f1895e2e51eb2c Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 12:15:42 -0500 Subject: [PATCH 37/62] Update save_all_plots() test --- tests/testthat/test-save_all_plots.R | 66 +++++----------------------- 1 file changed, 10 insertions(+), 56 deletions(-) diff --git a/tests/testthat/test-save_all_plots.R b/tests/testthat/test-save_all_plots.R index 5b45fc75..d58814e2 100644 --- a/tests/testthat/test-save_all_plots.R +++ b/tests/testthat/test-save_all_plots.R @@ -23,71 +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", - "pop.baa_figure.rda", - "catch_figure.rda", + "CPUE.indices_figure.rda", + "fishing.mortality_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", - "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) -}) - -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", + "natural.mortality_figure.rda", "pop.baa_figure.rda", - "catch_figure.rda", - "landings_figure.rda", "pop.caa_figure.rda", "pop.naa_figure.rda", - "recruitment.deviations_figure.rda", "recruitment_figure.rda", - "spawning.biomass_figure.rda" + "recruitment.deviations_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", @@ -97,6 +50,7 @@ test_that("save_all_plots works when some figures/tables are not plotted", { # 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) From 90f449326e33e44d75f26d55f2d2185bd2ae4684 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 12:35:42 -0500 Subject: [PATCH 38/62] Fix example error; update documentation --- R/process_data.R | 2 +- man/plot_error.Rd | 10 +++++----- man/plot_indices.Rd | 1 + man/process_table.Rd | 2 +- man/table_landings.Rd | 8 ++++---- 5 files changed, 12 insertions(+), 11 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 60714f8d..84813770 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -345,7 +345,7 @@ process_data <- function( #' #' @examples { #' filtered <- filter_data( -#' dat = dat, +#' dat = stockplotr:::example_data, #' label_name = "landings", #' geom = "line", #' era = "time" diff --git a/man/plot_error.Rd b/man/plot_error.Rd index c028d37e..d1386808 100644 --- a/man/plot_error.Rd +++ b/man/plot_error.Rd @@ -21,19 +21,19 @@ plot_error( \item{dat}{filtered data frame from standard output file(s) preformatted for 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 43036c5c..a4cb7b5f 100644 --- a/man/plot_indices.Rd +++ b/man/plot_indices.Rd @@ -68,4 +68,5 @@ plot_indices( dat = stockplotr:::example_data, unit_label = "fish/hr", interactive= FALSE) + } diff --git a/man/process_table.Rd b/man/process_table.Rd index 29c91879..d2e5b5e7 100644 --- a/man/process_table.Rd +++ b/man/process_table.Rd @@ -25,7 +25,7 @@ Processing for tables \examples{ { filtered <- filter_data( -dat = dat, +dat = stockplotr:::example_data, label_name = "landings", geom = "line", era = "time" diff --git a/man/table_landings.Rd b/man/table_landings.Rd index 07cfbb9d..95f999b0 100644 --- a/man/table_landings.Rd +++ b/man/table_landings.Rd @@ -11,20 +11,20 @@ table_landings( interactive = TRUE, module = NULL, scale_amount = 1, - label = "landings_weight", + 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 +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 +\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 From 45b17d38bb57b5e7b1fbc1b4923294e8b34a2b97 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 16:55:06 -0500 Subject: [PATCH 39/62] Add row in the alt text/captions csv for new figure: relative fishing mortality --- inst/resources/captions_alt_text_template.csv | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/resources/captions_alt_text_template.csv b/inst/resources/captions_alt_text_template.csv index a8b1b4b6..ff06daaa 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." From 1e7b43c3aea2bba988d772182fbafa0e8105de36 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 17:03:09 -0500 Subject: [PATCH 40/62] add 'gt' to DESCRIPTION's Imports; remove flextable --- DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a444fc22..0c6199d3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,7 +37,6 @@ Depends: Imports: cli, dplyr, - flextable, fs, ggplot2, glue, From 8f6e30c17c9b7c5be449211c131018ad2af0db8e Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Wed, 17 Dec 2025 17:23:06 -0500 Subject: [PATCH 41/62] Add theme for gt tables --- R/add_theme.R | 7 +++++-- R/table_landings.R | 6 ++++-- 2 files changed, 9 insertions(+), 4 deletions(-) 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/table_landings.R b/R/table_landings.R index 6bbf6eb3..1916bd1d 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -110,6 +110,7 @@ table_landings <- function(dat, landings_colname <- paste0("Landings (", unit_label, ")") #TODO: Update add_theme() for gt tables + #TODO: ensure numeric columns rounded final_df <- table_data |> dplyr::rename(dplyr::any_of(capitalized_names)) |> dplyr::rename_with(~ gsub(target_label, "", .)) |> @@ -153,8 +154,9 @@ table_landings <- function(dat, } final <- final_df |> - gt::gt() - final + gt::gt() |> + add_theme() + # final # Progress: # for bsb, hake, vsnap, and stockplotr::example_data, cols are: # "Year", "Landings ()", "uncertainty" From c236542faad9f3dc5124b39e902e88e7bc1891d6 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Mon, 29 Dec 2025 12:10:37 -0500 Subject: [PATCH 42/62] Update table_landings() so that fleets are ordered properly, with a mix of numerically and alphabetically --- R/table_landings.R | 40 ++++++++++++++++++---------------------- man/table_landings.Rd | 18 +++++++++++------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index 1916bd1d..ff4a3106 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -2,6 +2,10 @@ #' #' @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". @@ -11,21 +15,19 @@ #' @export #' #' @examples -#' \dontrun{ -#' table_landings(dat) +#' table_landings(stockplotr::example_data) #' #' table_landings( -#' dat, +#' stockplotr::example_data, #' unit_label = "landings label", -#' end_year = 2024, -#' make_rda = TRUE, -#' tables_dir = getwd() +#' group = #' ) -#' } table_landings <- function(dat, unit_label = "mt", era = "time", interactive = TRUE, + group = NULL, + method = "sum", module = NULL, scale_amount = 1, label = NULL, @@ -38,7 +40,7 @@ table_landings <- function(dat, # identify output fig_or_table <- "table" - #TODO: add these args to the table_landings() args + #TODO: do group and facet need to be uncommented and updated? # Filter data for landings prepared_data <- filter_data( dat = dat, @@ -93,12 +95,14 @@ table_landings <- function(dat, # get fleet names fleets <- prepared_data2$fleet |> unique() |> - sort() + # 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 <- process_table( - dat = prepared_data2#, + dat = prepared_data2, # group = group, - # method = method + method = method ) # put table_data into a nice table @@ -109,7 +113,6 @@ table_landings <- function(dat, landings_colname <- paste0("Landings (", unit_label, ")") - #TODO: Update add_theme() for gt tables #TODO: ensure numeric columns rounded final_df <- table_data |> dplyr::rename(dplyr::any_of(capitalized_names)) |> @@ -131,9 +134,6 @@ table_landings <- function(dat, replacement = ""), .cols = everything() ) - - # dplyr::rename_with(~ gsub("__", "_", .)) |> - # Order columns by landings / cv / landings, etc. and with alphabetical fleets if (length(fleets) > 0){ @@ -141,10 +141,9 @@ table_landings <- function(dat, dplyr::select(-Year) |> colnames() fleet_codes <- stringr::str_extract(cols_to_sort, "(?<=- )[^ ]+") - order_index <- order(fleet_codes, - cols_to_sort, - decreasing = c(FALSE, FALSE), - method = "radix") + fleet_ranks <- stringr::str_rank(fleet_codes, numeric = TRUE) + # Order by those ranks, then by col names + order_index <- order(fleet_ranks, cols_to_sort) ordered_cols_to_sort <- cols_to_sort[order_index] final_df <- final_df |> dplyr::select( @@ -162,9 +161,6 @@ table_landings <- function(dat, # "Year", "Landings ()", "uncertainty" # for am, cols are: # "Landings (mt) - cbn", "cv - cbn", "Landings (mt) - cbs", "cv - cbs", etc - - # TODO: Check that numeric fleets show up in chronological - # order (currently, may list 1, 10, 11, 12, etc.) # export figure to rda if argument = T if (make_rda == TRUE) { diff --git a/man/table_landings.Rd b/man/table_landings.Rd index 95f999b0..de4145b6 100644 --- a/man/table_landings.Rd +++ b/man/table_landings.Rd @@ -9,6 +9,8 @@ table_landings( unit_label = "mt", era = "time", interactive = TRUE, + group = NULL, + method = "sum", module = NULL, scale_amount = 1, label = NULL, @@ -31,6 +33,12 @@ the current time. To plot all data, set era to NULL.} 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.} @@ -57,15 +65,11 @@ fleet and year. Landed catch by fleet and year table } \examples{ -\dontrun{ -table_landings(dat) +table_landings(stockplotr::example_data) table_landings( - dat, + stockplotr::example_data, unit_label = "landings label", - end_year = 2024, - make_rda = TRUE, - tables_dir = getwd() + group = ) } -} From 9df33c20b7e01b97eb4628ab574c19973bab2977 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Mon, 29 Dec 2025 12:16:51 -0500 Subject: [PATCH 43/62] Round landings and uncertainty cols in table_landings() --- R/table_landings.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/table_landings.R b/R/table_landings.R index ff4a3106..bef792e4 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -80,7 +80,9 @@ table_landings <- function(dat, } prepared_data2 <- prepared_data |> - dplyr::filter(label == target_label) + dplyr::filter(label == target_label) |> + dplyr::mutate(estimate = round(as.numeric(estimate), digits = 0)) |> + dplyr::mutate(uncertainty = round(as.numeric(uncertainty), digits = 2)) # get uncertainty label uncert_lab <- prepared_data2$uncertainty_label |> From a802ca697da7c7a8b0551951112d592d58c33196 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Mon, 29 Dec 2025 13:55:12 -0500 Subject: [PATCH 44/62] Select first label if provided >1, in table_landings() --- R/table_landings.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index bef792e4..722417e3 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -54,10 +54,6 @@ table_landings <- function(dat, interactive = interactive ) - - #TODO: add check for if length of label > 1 (if TRUE, then a specific value (e.g., observed?) will need to be selected) - - # order potential labels by applicability ordered_labels <- c("landings_weight", "landings_numbers", @@ -75,6 +71,10 @@ table_landings <- function(dat, } } cli::cli_alert_info("`label` selected as {target_label}.") + } else if (length(label) > 1){ + cli::cli_alert_info("More than one `label` exists.") + target_label <- label[1] + cli::cli_alert_info("The first `label` value will be selected {target_label}.") } else { target_label <- label } @@ -115,7 +115,6 @@ table_landings <- function(dat, landings_colname <- paste0("Landings (", unit_label, ")") - #TODO: ensure numeric columns rounded final_df <- table_data |> dplyr::rename(dplyr::any_of(capitalized_names)) |> dplyr::rename_with(~ gsub(target_label, "", .)) |> From a6a1cf29cec961640b7d15011ecca53a973248ec Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Tue, 6 Jan 2026 17:18:35 -0500 Subject: [PATCH 45/62] make adjustments to table_landings --- R/convert_output.R | 2 +- R/process_data.R | 10 +++++--- R/table_landings.R | 63 +++++++++++++++++++++++++++++++++++++++------- 3 files changed, 61 insertions(+), 14 deletions(-) diff --git a/R/convert_output.R b/R/convert_output.R index 632af573..b556b724 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.") } diff --git a/R/process_data.R b/R/process_data.R index 84813770..6fcbfe82 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -388,15 +388,17 @@ process_table <- function( id_group <- index_variables[-grepl("year|age|length_bin", index_variables)] cols <- index_variables[grepl("year|age|length_bin", index_variables)] + uncert_lab <- unique(dat$uncertainty_label) table_data <- dat |> dplyr::select(dplyr::all_of(c( - "label", "model", index_variables, "estimate", "uncertainty_label", "uncertainty" + "label", "model", index_variables, "estimate", "uncertainty" ))) |> + dplyr::rename(!!uncert_lab := uncertainty) |> tidyr::pivot_wider( - id_cols = dplyr::all_of(c(cols)), - values_from = dplyr::all_of(c("estimate", "uncertainty")), - names_from = dplyr::all_of(c("label", "uncertainty_label", "model", id_group))) + id_cols = dplyr::all_of(c(cols, "model")), + values_from = dplyr::all_of(c("estimate", uncert_lab)), + names_from = dplyr::all_of(c("label", id_group))) table_data } diff --git a/R/table_landings.R b/R/table_landings.R index 722417e3..49eb5bc2 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -8,7 +8,10 @@ #' 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". +#' @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. @@ -54,14 +57,54 @@ table_landings <- function(dat, interactive = interactive ) + # Add check for length label >1 + # below method will only work when unqiue(label) == 2 + if (length(unique(prepared_data$label)) > 1){ + cli::cli_alert_info("Multiple labels found in prepared data: {unique(prepared_data$label)}") + # check if the multiple labels are equal for all indexing + # all non-indexing variables + indexing_vars <- colnames(prepared_data)[-grep( + paste( + c("year", "estimate", + "uncertainty", "uncertainty_label", + "label", "module_name", + "likelihood", "initial"), + collapse = "|"), colnames(prepared_data))] + + # compare estimate across all indexing vars and see if they are different over years + label_differences <- prepared_data |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(indexing_vars), + names_from = label, + values_from = estimate + ) |> + dplyr::mutate( + diff = .data[[unique(prepared_data$label)[1]]] - .data[[unique(prepared_data$label)[2]]] + ) + + if (all(label_differences$diff == 0)){ + cli::cli_alert_info("Labels have identical values. Using only the first label: {unique(prepared_data$label)[1]}") + prepared_data <- prepared_data |> + dplyr::filter(label == unique(prepared_data$label)[1]) + multi_label <- FALSE + } else { + multi_label <- TRUE + } + } + # order potential labels by applicability - ordered_labels <- c("landings_weight", - "landings_numbers", - "landings_expected", - "landings_predicted", - "landings") + ordered_labels <- c( + # "landings_weight", + # "landings_numbers", + # "landings_expected", + # "landings_predicted", + "landings_observed_weight", + "landings_predicted_weight", + "landings_observed_number", + "landings_predicted_number", + "landings") - if (is.null(label)){ + if (is.null(label) & multi_label){ cli::cli_alert_info("`label` not specified.") # Choose label to filter by, based on presence in prepared_data for (lab in ordered_labels) { @@ -71,12 +114,14 @@ table_landings <- function(dat, } } cli::cli_alert_info("`label` selected as {target_label}.") - } else if (length(label) > 1){ + } else if (length(label) > 1 & multi_label){ cli::cli_alert_info("More than one `label` exists.") target_label <- label[1] cli::cli_alert_info("The first `label` value will be selected {target_label}.") - } else { + } else if (!is.null(label)){ target_label <- label + } else { + target_label <- unique(prepared_data$label) } prepared_data2 <- prepared_data |> From b93cc897926fc8788bed4ad26ef025b71ded243e Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Wed, 7 Jan 2026 11:24:41 -0500 Subject: [PATCH 46/62] move knitr back into suggests --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0c6199d3..bc8c1a2f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,7 +43,6 @@ Imports: gt, httr, kableExtra, - knitr, naniar, prodlim, quarto, @@ -56,6 +55,7 @@ Imports: withr Suggests: here, + knitr, rmarkdown, testthat (>= 3.0.0) VignetteBuilder: From e15139929453faf5c6134f4a6f759625c59cef66 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Wed, 7 Jan 2026 11:25:26 -0500 Subject: [PATCH 47/62] update process_table so that it does most of the post filtering processing to get to a mostly table ready data set --- R/process_data.R | 47 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 7 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 6fcbfe82..ec2e4f75 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -334,7 +334,7 @@ process_data <- function( ) } - +#------------------------------------------------------------------------------- #' Processing for tables #' @@ -389,16 +389,49 @@ process_table <- function( id_group <- index_variables[-grepl("year|age|length_bin", index_variables)] cols <- index_variables[grepl("year|age|length_bin", index_variables)] uncert_lab <- unique(dat$uncertainty_label) + estimate_lab <- stringr::str_to_title(unique(dat$label)[1]) table_data <- dat |> + dplyr::rename_with( + ~ stringr::str_to_title(.x), + .cols = dplyr::all_of(index_variables) + ) |> dplyr::select(dplyr::all_of(c( - "label", "model", index_variables, "estimate", "uncertainty" + "model", stringr::str_to_title(index_variables), "estimate", "uncertainty" ))) |> - dplyr::rename(!!uncert_lab := uncertainty) |> + # rename uncertainty and capitalize indexing variables + estimate + dplyr::rename( + !!uncert_lab := uncertainty, + !!estimate_lab := estimate + ) |> tidyr::pivot_wider( - id_cols = dplyr::all_of(c(cols, "model")), - values_from = dplyr::all_of(c("estimate", uncert_lab)), - names_from = dplyr::all_of(c("label", id_group))) + id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), + values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), + names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + + # filter out NAs for cols columns + for (c in stringr::str_to_title(cols)){ + table_data <- dplyr::filter(table_data, !is.na(.data[[c]])) + } + + # If length of model > 1 then split into multiple dfs to a list + if (length(unique(table_data$model)) > 1){ + table_list <- list() + for (mod in unique(table_data$model)){ + mod_data <- dplyr::filter(table_data, model == mod) |> + dplyr::select(-model) + table_list[[mod]] <- mod_data + } + table_data <- table_list + } else { + table_list <- table_data |> + dplyr::select(-model) + } + + # Export as list + list( + table_list, + index_variables + ) - table_data } From e2c89c3e104c2527e89d4b3495975445ae17c5f1 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Wed, 7 Jan 2026 11:25:56 -0500 Subject: [PATCH 48/62] modify table_lanings to be more flexible and adjust based on new process_table --- R/table_landings.R | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index 49eb5bc2..154ae98b 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -25,21 +25,25 @@ #' unit_label = "landings label", #' group = #' ) -table_landings <- function(dat, - unit_label = "mt", - era = "time", - interactive = TRUE, - group = NULL, - method = "sum", - module = NULL, - scale_amount = 1, - label = NULL, - make_rda = FALSE, - tables_dir = getwd()) { +table_landings <- function( + dat, + unit_label = "mt", + era = "time", + interactive = TRUE, + group = NULL, + method = "sum", + module = NULL, + scale_amount = 1, + # Consider moving label out and make it automated - I set foundations for this + label = NULL, + make_rda = FALSE, + tables_dir = getwd()) { + # TODO: remove -- this gets called in create_rda @ end # create plot-specific variables to use throughout fxn for naming and IDing topic_label <- "landings" + # TODO: remove -- this gets called in create_rda @ end # identify output fig_or_table <- "table" @@ -104,6 +108,7 @@ table_landings <- function(dat, "landings_predicted_number", "landings") + # TODO: evaluate this step and see if it can be condensed with the changes if (is.null(label) & multi_label){ cli::cli_alert_info("`label` not specified.") # Choose label to filter by, based on presence in prepared_data @@ -146,12 +151,13 @@ table_landings <- function(dat, stringr::str_sort(numeric = TRUE) #TODO: fix this so that fleet names aren't removed if, e.g., group = "fleet" - table_data <- process_table( + table_data_info <- process_table( dat = prepared_data2, # group = group, method = method ) - + table_data <- table_data_info[[1]] + indexed_vars <- table_data_info[[2]] # put table_data into a nice table capitalized_names <- c("Year" = "year", "Sex" = "sex", From 9ea39814137d14c5672cf9074cf1239a65a00a51 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Wed, 7 Jan 2026 13:53:49 -0500 Subject: [PATCH 49/62] move columns in process_table so the indexed are next to each other i.e. estimate error estimate error --- R/process_data.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/process_data.R b/R/process_data.R index ec2e4f75..4c98cc32 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -414,6 +414,14 @@ process_table <- function( table_data <- dplyr::filter(table_data, !is.na(.data[[c]])) } + # group indexing data together (i.e. fleet) + if (length(id_group) > 0){ + for (f in unique(dat$fleet)) { + table_data <- table_data |> + dplyr::relocate(contains(f), .after = last_col()) + } + } + # If length of model > 1 then split into multiple dfs to a list if (length(unique(table_data$model)) > 1){ table_list <- list() From dc8ac2d7b301486481a3733cb979b37b3b8663b0 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Thu, 8 Jan 2026 09:14:14 -0500 Subject: [PATCH 50/62] final updates to table_landings and associated fxns --- R/process_data.R | 20 ++++++---- R/table_landings.R | 98 ++++++---------------------------------------- R/utils_rda.R | 15 ++++++- 3 files changed, 39 insertions(+), 94 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 4c98cc32..0dc690fd 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -403,11 +403,17 @@ process_table <- function( dplyr::rename( !!uncert_lab := uncertainty, !!estimate_lab := estimate - ) |> - tidyr::pivot_wider( - id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), - values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), - names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + ) + + # Only pivot wider if id_cols is >1 otherwise it's already in the correct format + if (length(id_group) > 0) { + table_data <- table_data |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), + values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), + names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + } + # filter out NAs for cols columns for (c in stringr::str_to_title(cols)){ @@ -416,7 +422,7 @@ process_table <- function( # group indexing data together (i.e. fleet) if (length(id_group) > 0){ - for (f in unique(dat$fleet)) { + for (f in unique(dat$fleet)) { # TODO: change dat$fleet to indexing col(s) table_data <- table_data |> dplyr::relocate(contains(f), .after = last_col()) } @@ -439,7 +445,7 @@ process_table <- function( # Export as list list( table_list, - index_variables + id_group ) } diff --git a/R/table_landings.R b/R/table_landings.R index 154ae98b..5c44cd6c 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -28,7 +28,7 @@ table_landings <- function( dat, unit_label = "mt", - era = "time", + era = NULL, interactive = TRUE, group = NULL, method = "sum", @@ -39,14 +39,6 @@ table_landings <- function( make_rda = FALSE, tables_dir = getwd()) { - # TODO: remove -- this gets called in create_rda @ end - # create plot-specific variables to use throughout fxn for naming and IDing - topic_label <- "landings" - - # TODO: remove -- this gets called in create_rda @ end - # identify output - fig_or_table <- "table" - #TODO: do group and facet need to be uncommented and updated? # Filter data for landings prepared_data <- filter_data( @@ -54,8 +46,6 @@ table_landings <- function( label_name = "landings", geom = "line", era = era, - # group = ifelse(length(group) > 1, group[1], group), - # facet = ifelse(length(group) > 1, group[-1], NULL), module = module, scale_amount = scale_amount, interactive = interactive @@ -158,6 +148,7 @@ table_landings <- function( ) table_data <- table_data_info[[1]] indexed_vars <- table_data_info[[2]] + # put table_data into a nice table capitalized_names <- c("Year" = "year", "Sex" = "sex", @@ -167,42 +158,11 @@ table_landings <- function( landings_colname <- paste0("Landings (", unit_label, ")") final_df <- table_data |> - dplyr::rename(dplyr::any_of(capitalized_names)) |> - dplyr::rename_with(~ gsub(target_label, "", .)) |> + # replace col names from unique(prepared_data2$label) with landings_colname dplyr::rename_with( - .fn = ~ paste0(landings_colname, "_", stringr::str_extract(., "[^_]+$")), - .cols = contains("estimate")) |> - dplyr::rename_with(~ gsub("_NA|_label", "", .)) |> - dplyr::rename_with( - # replace an underscore only if it's at the end of the colname - .fn = ~ stringr::str_replace(., pattern = "_$", replacement = ""), - .cols = everything() + ~ gsub(stringr::str_to_title(target_label), landings_colname, .) ) |> - dplyr::rename_with(~ gsub("uncertainty_", "", .)) |> - dplyr::rename_with(~ gsub("_", " - ", .)) |> - dplyr::rename_with( - .fn = ~ stringr::str_replace(., - pattern = "^ - ", - replacement = ""), - .cols = everything() - ) - - # Order columns by landings / cv / landings, etc. and with alphabetical fleets - if (length(fleets) > 0){ - cols_to_sort <- final_df |> - dplyr::select(-Year) |> - colnames() - fleet_codes <- stringr::str_extract(cols_to_sort, "(?<=- )[^ ]+") - fleet_ranks <- stringr::str_rank(fleet_codes, numeric = TRUE) - # Order by those ranks, then by col names - order_index <- order(fleet_ranks, cols_to_sort) - ordered_cols_to_sort <- cols_to_sort[order_index] - final_df <- final_df |> - dplyr::select( - Year, - dplyr::all_of(ordered_cols_to_sort) - ) - } + dplyr::rename_with(~ gsub("_", " - ", .)) final <- final_df |> gt::gt() |> @@ -216,47 +176,15 @@ table_landings <- function( # 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 - ) - - # create LaTeX-based table - latex_table <- create_latex_table(data = final_df, - caption = caps_alttext[1], - label = "landings_latex") - - export_rda( + create_rda( object = final, - caps_alttext = caps_alttext, - figures_tables_dir = tables_dir, - topic_label = topic_label, - fig_or_table = fig_or_table, - latex_table = latex_table + topic_label = "landings", + fig_or_table = "table", + dat = dat, + dir = tables_dir, + scale_amount = scale_amount, + unit_label = unit_label, + table_df = final_df ) } # Return finished table diff --git a/R/utils_rda.R b/R/utils_rda.R index b95f66ad..335d7ada 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 ) } From 0d6671b05f6ab351e2c30c942cc5b48b87c4c8cd Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Thu, 8 Jan 2026 16:12:02 -0500 Subject: [PATCH 51/62] move parts that processed the data out of landings and into process_table --- R/process_data.R | 53 +++++++++++++++++++- R/table_landings.R | 117 ++++++++++++--------------------------------- 2 files changed, 82 insertions(+), 88 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 0dc690fd..46bd4ac7 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -355,10 +355,61 @@ process_data <- function( process_table <- function( dat, group = NULL, - method = "sum"){ + method = "sum", + label = NULL){ index_variables <- check_grouping(dat) + # 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 { + if (length(unique(prepared_data$label)) > 1){ + if (length(unique(prepared_data$label)) == 2){ + # compare estimate across all indexing vars and see if they are different over years + label_differences <- dat |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(index_variables), + names_from = label, + values_from = estimate + ) |> + dplyr::mutate( + diff = .data[[unique(dat$label)[1]]] - .data[[unique(dat$label)[2]]] + ) + + if (all(label_differences$diff == 0)){ + cli::cli_alert_info("Labels have identical values. Using only the first label: {unique(prepared_data$label)[1]}") + dat <- dat |> + dplyr::filter(label == unique(dat$label)[1]) + } + } 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) + } + } + } + #TODO: calculate error properly, if summarized if (!is.null(group) && group == "none"){ dat <- switch( diff --git a/R/table_landings.R b/R/table_landings.R index 5c44cd6c..0c2451fa 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -50,82 +50,13 @@ table_landings <- function( scale_amount = scale_amount, interactive = interactive ) - - # Add check for length label >1 - # below method will only work when unqiue(label) == 2 - if (length(unique(prepared_data$label)) > 1){ - cli::cli_alert_info("Multiple labels found in prepared data: {unique(prepared_data$label)}") - # check if the multiple labels are equal for all indexing - # all non-indexing variables - indexing_vars <- colnames(prepared_data)[-grep( - paste( - c("year", "estimate", - "uncertainty", "uncertainty_label", - "label", "module_name", - "likelihood", "initial"), - collapse = "|"), colnames(prepared_data))] - # compare estimate across all indexing vars and see if they are different over years - label_differences <- prepared_data |> - tidyr::pivot_wider( - id_cols = dplyr::all_of(indexing_vars), - names_from = label, - values_from = estimate - ) |> - dplyr::mutate( - diff = .data[[unique(prepared_data$label)[1]]] - .data[[unique(prepared_data$label)[2]]] - ) - - if (all(label_differences$diff == 0)){ - cli::cli_alert_info("Labels have identical values. Using only the first label: {unique(prepared_data$label)[1]}") - prepared_data <- prepared_data |> - dplyr::filter(label == unique(prepared_data$label)[1]) - multi_label <- FALSE - } else { - multi_label <- TRUE - } - } - - # order potential labels by applicability - ordered_labels <- c( - # "landings_weight", - # "landings_numbers", - # "landings_expected", - # "landings_predicted", - "landings_observed_weight", - "landings_predicted_weight", - "landings_observed_number", - "landings_predicted_number", - "landings") - - # TODO: evaluate this step and see if it can be condensed with the changes - if (is.null(label) & multi_label){ - cli::cli_alert_info("`label` not specified.") - # Choose label to filter by, based on presence in prepared_data - for (lab in ordered_labels) { - if (lab %in% prepared_data$label) { - target_label <- lab - break - } - } - cli::cli_alert_info("`label` selected as {target_label}.") - } else if (length(label) > 1 & multi_label){ - cli::cli_alert_info("More than one `label` exists.") - target_label <- label[1] - cli::cli_alert_info("The first `label` value will be selected {target_label}.") - } else if (!is.null(label)){ - target_label <- label - } else { - target_label <- unique(prepared_data$label) - } - - prepared_data2 <- prepared_data |> - dplyr::filter(label == target_label) |> + prepared_data <- prepared_data |> dplyr::mutate(estimate = round(as.numeric(estimate), digits = 0)) |> dplyr::mutate(uncertainty = round(as.numeric(uncertainty), digits = 2)) # get uncertainty label - uncert_lab <- prepared_data2$uncertainty_label |> + uncert_lab <- prepared_data$uncertainty_label |> unique() if (length(uncert_lab) > 1){ @@ -135,38 +66,50 @@ table_landings <- function( } # get fleet names - fleets <- prepared_data2$fleet |> + fleets <- prepared_data$fleet |> unique() |> # 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_data2, + dat = prepared_data, # group = group, method = method ) table_data <- table_data_info[[1]] indexed_vars <- table_data_info[[2]] - # put table_data into a nice table - capitalized_names <- c("Year" = "year", - "Sex" = "sex", - "Fleet" = "fleet", - "Model" = "model") + # TODO: add check if there is a landings column for every error column -- if not remove the error (can keep landings) landings_colname <- paste0("Landings (", unit_label, ")") - final_df <- table_data |> - # replace col names from unique(prepared_data2$label) with landings_colname - dplyr::rename_with( - ~ gsub(stringr::str_to_title(target_label), landings_colname, .) - ) |> - dplyr::rename_with(~ gsub("_", " - ", .)) + if (!is.data.frame(table_data)) { + table_data <- lapply(table_data, function(df) { + df |> + dplyr::rename_with( + ~ gsub(stringr::str_to_title(target_label), landings_colname, .) + ) |> + dplyr::rename_with(~ gsub("_", " - ", .)) + }) + final <- lapply(table_data, function(df) { + df |> + gt::gt() |> + add_theme() + }) + } else { + final_df <- table_data |> + # replace col names from unique(prepared_data2$label) with landings_colname + dplyr::rename_with( + ~ gsub(stringr::str_to_title(target_label), landings_colname, .) + ) |> + dplyr::rename_with(~ gsub("_", " - ", .)) + + final <- final_df |> + gt::gt() |> + add_theme() + } - final <- final_df |> - gt::gt() |> - add_theme() # final # Progress: # for bsb, hake, vsnap, and stockplotr::example_data, cols are: From 9400fe17d9732838dfe12c488f09052babc98483 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 9 Jan 2026 14:02:30 -0500 Subject: [PATCH 52/62] add new processing function for tables to identify repetitive columns with different names --- R/utils_table.R | 70 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) diff --git a/R/utils_table.R b/R/utils_table.R index 7629df78..2433cba5 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -97,3 +97,73 @@ create_latex_table <- function(data, # 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 + +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)) == 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(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 +} From 783acc46cf640879b3f54a9cf4f7eca0e08c6cf9 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 9 Jan 2026 14:02:58 -0500 Subject: [PATCH 53/62] begin to make adjustments to fxns to check conditions for multiple models --- R/process_data.R | 158 ++++++++++++++++++++++++++++++++++----------- R/table_landings.R | 155 ++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 261 insertions(+), 52 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 46bd4ac7..677ad114 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -200,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) @@ -301,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 @@ -339,6 +326,7 @@ process_data <- function( #' 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 @@ -358,7 +346,18 @@ process_table <- function( method = "sum", label = NULL){ - index_variables <- check_grouping(dat) + 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 @@ -366,24 +365,20 @@ process_table <- function( dat <- dat |> dplyr::filter(label %in% label) } else { - if (length(unique(prepared_data$label)) > 1){ - if (length(unique(prepared_data$label)) == 2){ + # 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 - label_differences <- dat |> - tidyr::pivot_wider( - id_cols = dplyr::all_of(index_variables), - names_from = label, - values_from = estimate - ) |> - dplyr::mutate( - diff = .data[[unique(dat$label)[1]]] - .data[[unique(dat$label)[2]]] - ) - - if (all(label_differences$diff == 0)){ - cli::cli_alert_info("Labels have identical values. Using only the first label: {unique(prepared_data$label)[1]}") - dat <- dat |> - dplyr::filter(label == unique(dat$label)[1]) - } + #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + dat <- check_label_differences(dat, index_variables) } else { cli::cli_alert_info("Multiple labels detected.") if (interactive()) { @@ -406,9 +401,45 @@ process_table <- function( } dat <- dat |> dplyr::filter(label %in% selected_label) - } - } - } + # Check if any of the selected labels are the same values + dat2 <- check_label_differences(dat, index_variables, id_group) + # label_differences <- dat |> + # tidyr::pivot_wider( + # id_cols = dplyr::all_of(c(unique(index_variables), "model")), + # 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(!is.na(fleet)) |> + # dplyr::summarise(across(unique(dat$label), ~ all(is.na(.)))) + # col_to_remove <- names(empty_check)[which(as.logical(empty_check))] + # dat <- dplyr::filter(dat, label %notin% col_to_remove) + # # Identify if any of the columns are identical then remove one of the identical columns + # if (length(unique(prepared_data$label)) == 2){ + # # compare estimate across all indexing vars and see if they are different over years + # label_differences <- dat |> + # tidyr::pivot_wider( + # id_cols = dplyr::all_of(c(index_variables, "model")), + # names_from = label, + # values_from = estimate + # ) |> + # dplyr::mutate( + # diff = .data[[unique(dat$label)[1]]] - .data[[unique(dat$label)[2]]] + # ) + # + # if (all(label_differences$diff == 0)){ + # cli::cli_alert_info("Labels have identical values. Using only the first label: {unique(prepared_data$label)[1]}") + # dat <- dat |> + # dplyr::filter(label == unique(dat$label)[1]) + # } + # } else { + # cli::cli_alert_danger("Multiple labels with differing values detected. Function may not work as intended. Please leave an issue on GitHub.") + # } # close secondary statement of labels == 2 if removing under situation labels was >2 + } # 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"){ @@ -436,11 +467,62 @@ process_table <- function( cli::cli_alert_info("Output will contain indexing variables ({index_variables}).") } } - - id_group <- index_variables[-grepl("year|age|length_bin", index_variables)] - cols <- index_variables[grepl("year|age|length_bin", index_variables)] + uncert_lab <- unique(dat$uncertainty_label) - estimate_lab <- stringr::str_to_title(unique(dat$label)[1]) + estimate_lab <- stringr::str_to_title(stringr::str_replace_all(unique(dat$label), "_", " ")) + + if (length(estimate_lab) > 1) { + table_data <- dat |> + dplyr::rename_with( + ~ stringr::str_to_title(.x), + .cols = dplyr::all_of(index_variables) + ) |> + dplyr::rename(!!uncert_lab := uncertainty) |> + dplyr::select(dplyr::all_of(c( + "label", "model", stringr::str_to_title(index_variables), "estimate", uncert_lab + ))) |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c("model", stringr::str_to_title(index_variables))), + names_from = dplyr::all_of("label"), + values_from = dplyr::all_of(c("estimate", uncert_lab)) + ) |> + # rename uncertainty and capitalize indexing variables + estimate + dplyr::rename( + !!estimate_lab := estimate + ) + + # Only pivot wider if id_cols is >1 otherwise it's already in the correct format + if (length(id_group) > 0) { + table_data <- table_data |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), + values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), + names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + } + } else { + table_data <- dat |> + dplyr::rename_with( + ~ stringr::str_to_title(.x), + .cols = dplyr::all_of(index_variables) + ) |> + dplyr::select(dplyr::all_of(c( + "model", stringr::str_to_title(index_variables), "estimate", "uncertainty" + ))) |> + # rename uncertainty and capitalize indexing variables + estimate + dplyr::rename( + !!uncert_lab := uncertainty, + !!estimate_lab := estimate + ) + + # Only pivot wider if id_cols is >1 otherwise it's already in the correct format + if (length(id_group) > 0) { + table_data <- table_data |> + tidyr::pivot_wider( + id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), + values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), + names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + } + } table_data <- dat |> dplyr::rename_with( diff --git a/R/table_landings.R b/R/table_landings.R index 0c2451fa..34fae317 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -34,7 +34,6 @@ table_landings <- function( method = "sum", module = NULL, scale_amount = 1, - # Consider moving label out and make it automated - I set foundations for this label = NULL, make_rda = FALSE, tables_dir = getwd()) { @@ -56,9 +55,11 @@ table_landings <- function( dplyr::mutate(uncertainty = round(as.numeric(uncertainty), digits = 2)) # get uncertainty label - uncert_lab <- prepared_data$uncertainty_label |> - unique() + uncert_lab <- unique(prepared_data$uncertainty_label) + # Remove NA if present + uncert_lab <- uncert_lab[!is.na(uncert_lab)] + # This needs to be adjusted when comparing different models and diff error if (length(uncert_lab) > 1){ cli::cli_alert_warning("More than one value for uncertainty exists: {uncert_lab}") uncert_lab <- uncert_lab[[1]] @@ -66,8 +67,7 @@ table_landings <- function( } # get fleet names - fleets <- prepared_data$fleet |> - unique() |> + fleets <- unique(prepared_data$fleet) |> # sort numerically even if fleets are 100% characters stringr::str_sort(numeric = TRUE) @@ -75,40 +75,167 @@ table_landings <- function( table_data_info <- process_table( dat = prepared_data, # group = group, - method = method + method = method, + label = label ) table_data <- table_data_info[[1]] indexed_vars <- table_data_info[[2]] # TODO: add check if there is a landings column for every error column -- if not remove the error (can keep landings) - landings_colname <- paste0("Landings (", unit_label, ")") - + # TODO: TEST !!! if (!is.data.frame(table_data)) { - table_data <- lapply(table_data, function(df) { - df |> - dplyr::rename_with( - ~ gsub(stringr::str_to_title(target_label), landings_colname, .) - ) |> + # lapply made with the help of Gemini (all recoding names code is original) + df_list <- lapply(df_list, function(table_data) { + + landings_cols_init <- colnames(table_data)[ + grepl("landings", tolower(colnames(table_data))) + ] + + # CONDITION: Only proceed if landings columns actually exist in this data frame + if (length(landings_cols_init) > 0) { + # Clean up fleet names and keywords + landings_cols_new <- stringr::str_remove_all( + landings_cols_init, + paste0("_", fleets, collapse = "|") + ) + # Drop "weight" or "number" if present + landings_cols_new <- unique( + stringr::str_remove_all(landings_cols_new, " Number| Weight") + ) + # Check if we should simplify to a single "Landings" label + if (length(unique(landings_cols_new)) == 1) { + landings_cols_new <- "Landings" + } + + # Add units + landings_cols_new <- paste0(landings_cols_new, " (", unit_label, ")") + + # Re-attach fleet names to the new labels + cols_fleets <- stringr::str_extract( + landings_cols_init, + paste0(fleets, collapse = "|") + ) + + # Final target labels + final_names <- paste0(landings_cols_new, " - ", cols_fleets) + + # Create a named vector for renaming: c(new_name = old_name) + # This handles the "Rename this specific old name to this specific new name" + rename_map <- setNames(landings_cols_init, final_names) + + # Apply the renaming + table_data <- table_data |> + dplyr::rename(any_of(rename_map)) + } + + # Apply the general underscore formatting to ALL columns (regardless of landings) + table_data <- table_data |> dplyr::rename_with(~ gsub("_", " - ", .)) + return(table_data) }) + # transform dfs into tables final <- lapply(table_data, function(df) { df |> gt::gt() |> add_theme() }) } else { + # Determine target label(s) for landings based on available labels in data + # If 1 label -> "Landings" + # if > 1 label -> drop "weight" or "number" if present + landings_cols_init <- colnames(table_data)[ + grepl("landings", tolower(colnames(table_data))) + ] + landings_cols_new <- stringr::str_remove_all( + landings_cols_init, + paste0("_", fleets,collapse = "|")) + # drop "weight" or "number" if present + # Potential for users to want both? + landings_cols_new <- unique( + stringr::str_remove_all(landings_cols_new, " Number| Weight")) + + # test if all labels are the same in landings_cols + if (length(unique(landings_cols_new)) == 1) { + landings_cols_new <- "Landings" + } + # Add unit label to landings colnames + landings_cols_new <- paste0( + landings_cols_new, + " (", unit_label, ")") + # Extract fleets from landings_cols_init + cols_fleets <- unlist(stringr::str_extract_all( + landings_cols_init, + paste0(fleets, collapse = "|") + )) + landings_cols_new <- paste0(landings_cols_new, " - ", cols_fleets) + final_df <- table_data |> # replace col names from unique(prepared_data2$label) with landings_colname dplyr::rename_with( ~ gsub(stringr::str_to_title(target_label), landings_colname, .) ) |> dplyr::rename_with(~ gsub("_", " - ", .)) - + # Turn df into table final <- final_df |> gt::gt() |> add_theme() } + # + # if (!is.data.frame(table_data)) { + # table_data <- lapply(table_data, function(df) { + # df |> + # dplyr::rename_with( + # ~ gsub(stringr::str_to_title(target_label), landings_colname, .) + # ) |> + # dplyr::rename_with(~ gsub("_", " - ", .)) + # }) + # final <- lapply(table_data, function(df) { + # df |> + # gt::gt() |> + # add_theme() + # }) + # } else { + # # Determine target label(s) for landings based on available labels in data + # # If 1 label -> "Landings" + # # if > 1 label -> drop "weight" or "number" if present + # landings_cols_init <- colnames(table_data)[ + # grepl("landings", tolower(colnames(table_data))) + # ] + # landings_cols_new <- stringr::str_remove_all( + # landings_cols_init, + # paste0("_", fleets,collapse = "|")) + # # drop "weight" or "number" if present + # # Potential for users to want both? + # landings_cols_new <- unique( + # stringr::str_remove_all(landings_cols_new, " Number| Weight")) + # + # # test if all labels are the same in landings_cols + # if (length(unique(landings_cols_new)) == 1) { + # landings_cols_new <- "Landings" + # } + # # Add unit label to landings colnames + # landings_cols_new <- paste0( + # landings_cols_new, + # " (", unit_label, ")") + # # Extract fleets from landings_cols_init + # cols_fleets <- unlist(stringr::str_extract_all( + # landings_cols_init, + # paste0(fleets, collapse = "|") + # )) + # landings_cols_new <- paste0(landings_cols_new, " - ", cols_fleets) + # + # final_df <- table_data |> + # # replace col names from unique(prepared_data2$label) with landings_colname + # dplyr::rename_with( + # ~ gsub(stringr::str_to_title(target_label), landings_colname, .) + # ) |> + # dplyr::rename_with(~ gsub("_", " - ", .)) + # + # final <- final_df |> + # gt::gt() |> + # add_theme() + # } # final # Progress: From 480c414bc7984263863829fd42bdbb6bc9d3451a Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 9 Jan 2026 15:25:33 -0500 Subject: [PATCH 54/62] adust process_tables more to work with multiple models and dynamic possibilities for indexing --- R/process_data.R | 178 ++++++++++++++++++++++----------------------- R/table_landings.R | 20 +++-- 2 files changed, 100 insertions(+), 98 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 677ad114..9f09855f 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -471,109 +471,107 @@ process_table <- function( uncert_lab <- unique(dat$uncertainty_label) estimate_lab <- stringr::str_to_title(stringr::str_replace_all(unique(dat$label), "_", " ")) - if (length(estimate_lab) > 1) { - table_data <- dat |> - dplyr::rename_with( - ~ stringr::str_to_title(.x), - .cols = dplyr::all_of(index_variables) - ) |> - dplyr::rename(!!uncert_lab := uncertainty) |> - dplyr::select(dplyr::all_of(c( - "label", "model", stringr::str_to_title(index_variables), "estimate", uncert_lab - ))) |> - tidyr::pivot_wider( - id_cols = dplyr::all_of(c("model", stringr::str_to_title(index_variables))), - names_from = dplyr::all_of("label"), - values_from = dplyr::all_of(c("estimate", uncert_lab)) - ) |> - # rename uncertainty and capitalize indexing variables + estimate - dplyr::rename( - !!estimate_lab := estimate - ) + # if (length(estimate_lab) > 1 & length(unique(dat$model)) == 1){ + # table_data <- dat |> + # dplyr::rename_with( + # ~ stringr::str_to_title(.x), + # .cols = dplyr::all_of(unique(index_variables)) + # ) |> + # dplyr::rename(!!uncert_lab := uncertainty) |> + # dplyr::select(dplyr::all_of(c( + # "label", "model", stringr::str_to_title(index_variables), "estimate", uncert_lab + # ))) # |> + # # tidyr::pivot_wider( + # # id_cols = dplyr::all_of(c("model", stringr::str_to_title(index_variables))), + # # names_from = dplyr::all_of("label"), + # # values_from = dplyr::all_of(c("estimate", uncert_lab)) + # # ) |> + # # # rename uncertainty and capitalize indexing variables + estimate + # # dplyr::rename( + # # !!estimate_lab := estimate + # # ) + # + # # Only pivot wider if id_cols is >1 otherwise it's already in the correct format + # if (length(id_group) > 0) { + # table_data <- table_data |> + # tidyr::pivot_wider( + # id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), + # values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), + # names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + # } + # } else { + # table_data <- dat |> + # dplyr::rename_with( + # ~ stringr::str_to_title(.x), + # # .cols = dplyr::all_of(index_variables) + # ) |> + # dplyr::select(dplyr::all_of(c( + # "model", stringr::str_to_title(unique(index_variables)), "estimate", "uncertainty" + # ))) # |> + # # rename uncertainty and capitalize indexing variables + estimate + # # dplyr::rename( + # # !!uncert_lab := uncertainty, + # # !!estimate_lab := estimate + # # ) + # + # # Only pivot wider if id_cols is >1 otherwise it's already in the correct format + # if (length(id_group) > 0) { + # table_data <- table_data |> + # tidyr::pivot_wider( + # id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), + # values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), + # names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) + # } + # } + + table_list <- list() + for (i in length(unique(dat$model))){ + mod_dat <- dplyr::filter(dat, model == mod) + mod_index_variables <- unique(index_variables[names(index_variables) == mod]) + mod_id_group <- unique(id_group[names(id_group) == mod]) + mod_cols <- unique(cols[names(cols) == mod]) + mod_uncert_lab <- na.omit(unique(mod_dat$uncertainty_label)) - # Only pivot wider if id_cols is >1 otherwise it's already in the correct format - if (length(id_group) > 0) { - table_data <- table_data |> - tidyr::pivot_wider( - id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), - values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), - names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) - } - } else { - table_data <- dat |> + 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(index_variables) + .cols = dplyr::all_of(mod_index_variables) ) |> dplyr::select(dplyr::all_of(c( - "model", stringr::str_to_title(index_variables), "estimate", "uncertainty" + stringr::str_to_title(mod_index_variables), "label", "estimate", "uncertainty" ))) |> # rename uncertainty and capitalize indexing variables + estimate dplyr::rename( - !!uncert_lab := uncertainty, - !!estimate_lab := estimate - ) + !!mod_uncert_lab := uncertainty + ) |> # Only pivot wider if id_cols is >1 otherwise it's already in the correct format - if (length(id_group) > 0) { - table_data <- table_data |> + # if (length(mod_id_group) > 0) { + # table_data2 <- table_data |> tidyr::pivot_wider( - id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), - values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), - names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) - } - } - - table_data <- dat |> - dplyr::rename_with( - ~ stringr::str_to_title(.x), - .cols = dplyr::all_of(index_variables) - ) |> - dplyr::select(dplyr::all_of(c( - "model", stringr::str_to_title(index_variables), "estimate", "uncertainty" - ))) |> - # rename uncertainty and capitalize indexing variables + estimate - dplyr::rename( - !!uncert_lab := uncertainty, - !!estimate_lab := estimate - ) - - # Only pivot wider if id_cols is >1 otherwise it's already in the correct format - if (length(id_group) > 0) { - table_data <- table_data |> - tidyr::pivot_wider( - id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), - values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), - names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) - } + 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)))#, + # names_glue = "{.value}_{label}_{!!Fleet}" + ) |> + dplyr::rename_with(~ stringr::str_remove(., "^estimate_")) + # } else { + # mod_estimate_lab <- unique(table_data$label) + # table_data <- table_data |> + # dplyr::select(-label) |> + # dplyr::rename(!!mod_estimate_lab := estimate) + # } - - # filter out NAs for cols columns - for (c in stringr::str_to_title(cols)){ - table_data <- dplyr::filter(table_data, !is.na(.data[[c]])) - } - - # group indexing data together (i.e. fleet) - if (length(id_group) > 0){ - for (f in unique(dat$fleet)) { # TODO: change dat$fleet to indexing col(s) - table_data <- table_data |> - dplyr::relocate(contains(f), .after = last_col()) - } - } - - # If length of model > 1 then split into multiple dfs to a list - if (length(unique(table_data$model)) > 1){ - table_list <- list() - for (mod in unique(table_data$model)){ - mod_data <- dplyr::filter(table_data, model == mod) |> - dplyr::select(-model) - table_list[[mod]] <- mod_data + # group indexing data together (i.e. fleet) + if (length(id_group) > 0){ + for (f in unique(mod_dat$fleet)) { # TODO: change dat$fleet to indexing col(s) + table_data <- table_data |> + dplyr::relocate(contains(f), .after = last_col()) + } } - table_data <- table_list - } else { - table_list <- table_data |> - dplyr::select(-model) - } + table_list[[mod]] <- table_data + } # close loop # Export as list list( diff --git a/R/table_landings.R b/R/table_landings.R index 34fae317..2e7eb450 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -54,19 +54,23 @@ table_landings <- function( dplyr::mutate(estimate = round(as.numeric(estimate), digits = 0)) |> dplyr::mutate(uncertainty = round(as.numeric(uncertainty), digits = 2)) - # get uncertainty label - uncert_lab <- unique(prepared_data$uncertainty_label) - # Remove NA if present - uncert_lab <- uncert_lab[!is.na(uncert_lab)] + # get uncertainty label by model + uncert_lab <- prepared_data |> + dplyr::filter(!is.na(uncertainty_label)) |> + dplyr::group_by(model) |> + dplyr::summarise(unique_uncert = unique(uncertainty_label)) + uncert_lab <- 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){ + if (length(uncert_lab) > 1 & length(unique(prepared_data$model)) == 1){ 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.") } # 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) @@ -74,10 +78,10 @@ table_landings <- function( #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, + # group = group, method = method, - label = label - ) + label = label + ) table_data <- table_data_info[[1]] indexed_vars <- table_data_info[[2]] From 2b828962a70d4de2a7b389aeaa7c5722e61e92f5 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 9 Jan 2026 15:27:24 -0500 Subject: [PATCH 55/62] clean up process_table code --- R/process_data.R | 115 +++++------------------------------------------ 1 file changed, 11 insertions(+), 104 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index 9f09855f..a953f314 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -403,40 +403,6 @@ process_table <- function( dplyr::filter(label %in% selected_label) # Check if any of the selected labels are the same values dat2 <- check_label_differences(dat, index_variables, id_group) - # label_differences <- dat |> - # tidyr::pivot_wider( - # id_cols = dplyr::all_of(c(unique(index_variables), "model")), - # 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(!is.na(fleet)) |> - # dplyr::summarise(across(unique(dat$label), ~ all(is.na(.)))) - # col_to_remove <- names(empty_check)[which(as.logical(empty_check))] - # dat <- dplyr::filter(dat, label %notin% col_to_remove) - # # Identify if any of the columns are identical then remove one of the identical columns - # if (length(unique(prepared_data$label)) == 2){ - # # compare estimate across all indexing vars and see if they are different over years - # label_differences <- dat |> - # tidyr::pivot_wider( - # id_cols = dplyr::all_of(c(index_variables, "model")), - # names_from = label, - # values_from = estimate - # ) |> - # dplyr::mutate( - # diff = .data[[unique(dat$label)[1]]] - .data[[unique(dat$label)[2]]] - # ) - # - # if (all(label_differences$diff == 0)){ - # cli::cli_alert_info("Labels have identical values. Using only the first label: {unique(prepared_data$label)[1]}") - # dat <- dat |> - # dplyr::filter(label == unique(dat$label)[1]) - # } - # } else { - # cli::cli_alert_danger("Multiple labels with differing values detected. Function may not work as intended. Please leave an issue on GitHub.") - # } # close secondary statement of labels == 2 if removing under situation labels was >2 } # close else >2 labels } # close if >1 label in df } # close if label == NULL @@ -471,59 +437,6 @@ process_table <- function( uncert_lab <- unique(dat$uncertainty_label) estimate_lab <- stringr::str_to_title(stringr::str_replace_all(unique(dat$label), "_", " ")) - # if (length(estimate_lab) > 1 & length(unique(dat$model)) == 1){ - # table_data <- dat |> - # dplyr::rename_with( - # ~ stringr::str_to_title(.x), - # .cols = dplyr::all_of(unique(index_variables)) - # ) |> - # dplyr::rename(!!uncert_lab := uncertainty) |> - # dplyr::select(dplyr::all_of(c( - # "label", "model", stringr::str_to_title(index_variables), "estimate", uncert_lab - # ))) # |> - # # tidyr::pivot_wider( - # # id_cols = dplyr::all_of(c("model", stringr::str_to_title(index_variables))), - # # names_from = dplyr::all_of("label"), - # # values_from = dplyr::all_of(c("estimate", uncert_lab)) - # # ) |> - # # # rename uncertainty and capitalize indexing variables + estimate - # # dplyr::rename( - # # !!estimate_lab := estimate - # # ) - # - # # Only pivot wider if id_cols is >1 otherwise it's already in the correct format - # if (length(id_group) > 0) { - # table_data <- table_data |> - # tidyr::pivot_wider( - # id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), - # values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), - # names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) - # } - # } else { - # table_data <- dat |> - # dplyr::rename_with( - # ~ stringr::str_to_title(.x), - # # .cols = dplyr::all_of(index_variables) - # ) |> - # dplyr::select(dplyr::all_of(c( - # "model", stringr::str_to_title(unique(index_variables)), "estimate", "uncertainty" - # ))) # |> - # # rename uncertainty and capitalize indexing variables + estimate - # # dplyr::rename( - # # !!uncert_lab := uncertainty, - # # !!estimate_lab := estimate - # # ) - # - # # Only pivot wider if id_cols is >1 otherwise it's already in the correct format - # if (length(id_group) > 0) { - # table_data <- table_data |> - # tidyr::pivot_wider( - # id_cols = dplyr::all_of(c(stringr::str_to_title(cols), "model")), - # values_from = dplyr::all_of(c(estimate_lab, uncert_lab)), - # names_from = dplyr::all_of(c(stringr::str_to_title(id_group)))) - # } - # } - table_list <- list() for (i in length(unique(dat$model))){ mod_dat <- dplyr::filter(dat, model == mod) @@ -545,23 +458,12 @@ process_table <- function( dplyr::rename( !!mod_uncert_lab := uncertainty ) |> - - # Only pivot wider if id_cols is >1 otherwise it's already in the correct format - # if (length(mod_id_group) > 0) { - # table_data2 <- table_data |> - 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)))#, - # names_glue = "{.value}_{label}_{!!Fleet}" - ) |> - dplyr::rename_with(~ stringr::str_remove(., "^estimate_")) - # } else { - # mod_estimate_lab <- unique(table_data$label) - # table_data <- table_data |> - # dplyr::select(-label) |> - # dplyr::rename(!!mod_estimate_lab := estimate) - # } + 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(id_group) > 0){ @@ -573,6 +475,11 @@ process_table <- function( table_list[[mod]] <- table_data } # 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, From 45ec11f59200ca7af19e28a4bb2d954a31d133d5 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 9 Jan 2026 16:32:36 -0500 Subject: [PATCH 56/62] begin to dynamically adjust column names --- R/process_data.R | 11 +++++++++-- R/table_landings.R | 32 +++++++++++++++++++------------- 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index a953f314..b6f3530e 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -438,7 +438,8 @@ process_table <- function( estimate_lab <- stringr::str_to_title(stringr::str_replace_all(unique(dat$label), "_", " ")) table_list <- list() - for (i in length(unique(dat$model))){ + id_group_list <- list() + for (mod in unique(dat$model)){ mod_dat <- dplyr::filter(dat, model == mod) mod_index_variables <- unique(index_variables[names(index_variables) == mod]) mod_id_group <- unique(id_group[names(id_group) == mod]) @@ -473,6 +474,11 @@ process_table <- function( } } 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 @@ -483,7 +489,8 @@ process_table <- function( # Export as list list( table_list, - id_group + stringr::str_to_title(id_group), + id_group_list ) } diff --git a/R/table_landings.R b/R/table_landings.R index 2e7eb450..3fec6ad3 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -84,16 +84,18 @@ table_landings <- function( ) 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) # TODO: TEST !!! if (!is.data.frame(table_data)) { # lapply made with the help of Gemini (all recoding names code is original) - df_list <- lapply(df_list, function(table_data) { + df_list <- lapply(table_data, function(dat) { - landings_cols_init <- colnames(table_data)[ - grepl("landings", tolower(colnames(table_data))) + landings_cols_init <- colnames(dat)[ + grepl("landings", tolower(colnames(dat))) ] # CONDITION: Only proceed if landings columns actually exist in this data frame @@ -102,24 +104,28 @@ table_landings <- function( landings_cols_new <- stringr::str_remove_all( landings_cols_init, paste0("_", fleets, collapse = "|") - ) + ) |> stringr::str_replace_all("_", " ") # Drop "weight" or "number" if present landings_cols_new <- unique( - stringr::str_remove_all(landings_cols_new, " Number| Weight") + stringr::str_remove_all(tolower(landings_cols_new), " number| weight") ) # Check if we should simplify to a single "Landings" label - if (length(unique(landings_cols_new)) == 1) { - landings_cols_new <- "Landings" + if (length(unique(landings_cols_new)) == 2) { + matches <- sapply(uncert_lab, function(l) { + any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) + }) + id_uncert <- uncert_lab[matches] + landings_cols_new <- c(paste0("Landings (", unit_label, ")"), id_uncert) } # Add units - landings_cols_new <- paste0(landings_cols_new, " (", unit_label, ")") + # landings_cols_new <- paste0(landings_cols_new, " (", unit_label, ")") # Re-attach fleet names to the new labels cols_fleets <- stringr::str_extract( landings_cols_init, - paste0(fleets, collapse = "|") - ) + paste0("_",fleets, "$", collapse = "|") + ) |> stringr::str_remove_all("_") # Final target labels final_names <- paste0(landings_cols_new, " - ", cols_fleets) @@ -129,14 +135,14 @@ table_landings <- function( rename_map <- setNames(landings_cols_init, final_names) # Apply the renaming - table_data <- table_data |> + dat <- dat |> dplyr::rename(any_of(rename_map)) } # Apply the general underscore formatting to ALL columns (regardless of landings) - table_data <- table_data |> + dat <- dat |> dplyr::rename_with(~ gsub("_", " - ", .)) - return(table_data) + return(dat) }) # transform dfs into tables final <- lapply(table_data, function(df) { From 6f972d3b0ad1f28f688ef7f6d284dff0c54a79f3 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Mon, 12 Jan 2026 15:35:41 -0500 Subject: [PATCH 57/62] continue modifying function to allow customaizaiton -- honestly forgot to commit all day --- R/process_data.R | 32 ++++-- R/table_landings.R | 244 +++++++++++++++++++++++++-------------------- R/utils_table.R | 5 +- 3 files changed, 168 insertions(+), 113 deletions(-) diff --git a/R/process_data.R b/R/process_data.R index b6f3530e..557fb23e 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -401,8 +401,23 @@ process_table <- function( } 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 - dat2 <- check_label_differences(dat, index_variables, id_group) + dat <- check_label_differences(dat, index_variables, id_group) } # close else >2 labels } # close if >1 label in df } # close if label == NULL @@ -441,10 +456,15 @@ process_table <- function( id_group_list <- list() for (mod in unique(dat$model)){ mod_dat <- dplyr::filter(dat, model == mod) - mod_index_variables <- unique(index_variables[names(index_variables) == mod]) - mod_id_group <- unique(id_group[names(id_group) == mod]) - mod_cols <- unique(cols[names(cols) == mod]) - mod_uncert_lab <- na.omit(unique(mod_dat$uncertainty_label)) + 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 <- na.omit(uncert_lab) + } table_data <- mod_dat |> dplyr::filter(dplyr::if_all(dplyr::any_of(mod_cols), ~ !is.na(.))) |> @@ -467,7 +487,7 @@ process_table <- function( dplyr::rename_with(~ stringr::str_remove(., "^estimate_")) # group indexing data together (i.e. fleet) - if (length(id_group) > 0){ + 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(contains(f), .after = last_col()) diff --git a/R/table_landings.R b/R/table_landings.R index 3fec6ad3..99c898bf 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -48,9 +48,7 @@ table_landings <- function( module = module, scale_amount = scale_amount, interactive = interactive - ) - - prepared_data <- prepared_data |> + ) |> dplyr::mutate(estimate = round(as.numeric(estimate), digits = 0)) |> dplyr::mutate(uncertainty = round(as.numeric(uncertainty), digits = 2)) @@ -63,12 +61,14 @@ table_landings <- function( # 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(prepared_data$model)) == 1){ - cli::cli_alert_warning("More than one value for uncertainty exists: {uncert_lab}") + 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.") + # 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) |> @@ -86,16 +86,16 @@ table_landings <- function( 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) + # 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) # TODO: TEST !!! if (!is.data.frame(table_data)) { # lapply made with the help of Gemini (all recoding names code is original) - df_list <- lapply(table_data, function(dat) { + df_list <- lapply(table_data, function(tab_dat) { - landings_cols_init <- colnames(dat)[ - grepl("landings", tolower(colnames(dat))) + landings_cols_init <- colnames(tab_dat)[ + grepl("landings", tolower(colnames(tab_dat))) ] # CONDITION: Only proceed if landings columns actually exist in this data frame @@ -115,7 +115,14 @@ table_landings <- function( any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) }) id_uncert <- uncert_lab[matches] - landings_cols_new <- c(paste0("Landings (", unit_label, ")"), id_uncert) + landings_cols_new <- c( + ifelse( + uncert_lab == "uncertainty", + paste0("Landings (", unit_label, ")"), + paste0("Landings (", unit_label, ") (", id_uncert, ")") + ), + id_uncert) + # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column } # Add units @@ -128,24 +135,56 @@ table_landings <- function( ) |> stringr::str_remove_all("_") # Final target labels - final_names <- paste0(landings_cols_new, " - ", cols_fleets) + final_names <- ifelse( + is.na(cols_fleets), + landings_cols_new, + paste0(landings_cols_new, " - ", cols_fleets) + ) # Create a named vector for renaming: c(new_name = old_name) # This handles the "Rename this specific old name to this specific new name" rename_map <- setNames(landings_cols_init, final_names) # Apply the renaming - dat <- dat |> + tab_dat <- tab_dat |> dplyr::rename(any_of(rename_map)) + + # Comment out from here to closing brackets if don't want to combine label and uncertainty + # {{ ------------------------------------------------------------------- + # Use loop to combine label (uncertainty) + landings_cols <- grep(paste0("Landings \\(", unit_label, "\\)"), names(tab_dat), value = TRUE) + + for (l_col in landings_cols) { + # 1. Extract fleet from current landing column name + f_id <- stringr::str_extract(l_col, paste0(unique(cols_fleets), collapse = "|")) + + # 2. Construct the matching uncertainty column name + u_col <- paste0(id_uncert, " - ", f_id) + + # 3. Only perform the merge if the uncertainty column actually exists + if (u_col %in% names(tab_dat)) { + tab_dat[[l_col]] <- paste0( + tab_dat[[l_col]], + " (", tab_dat[[u_col]], ")" + ) + + # Optional: Clean up " (NA)" if they appear + tab_dat[[l_col]] <- stringr::str_remove(tab_dat[[l_col]], " \\(NA\\)") + } + } + # Remove error column(s) + tab_dat <- tab_dat |> + dplyr::select(-dplyr::matches(paste0(uncert_lab, " - ", fleets, collapse = "|"))) + # }} ------------------------------------------------------------------- } # Apply the general underscore formatting to ALL columns (regardless of landings) - dat <- dat |> + tab_dat <- tab_dat |> dplyr::rename_with(~ gsub("_", " - ", .)) - return(dat) + return(tab_dat) }) # transform dfs into tables - final <- lapply(table_data, function(df) { + final <- lapply(df_list, function(df) { df |> gt::gt() |> add_theme() @@ -157,102 +196,86 @@ table_landings <- function( landings_cols_init <- colnames(table_data)[ grepl("landings", tolower(colnames(table_data))) ] - landings_cols_new <- stringr::str_remove_all( - landings_cols_init, - paste0("_", fleets,collapse = "|")) - # drop "weight" or "number" if present - # Potential for users to want both? - landings_cols_new <- unique( - stringr::str_remove_all(landings_cols_new, " Number| Weight")) - # test if all labels are the same in landings_cols - if (length(unique(landings_cols_new)) == 1) { - landings_cols_new <- "Landings" + # CONDITION: Only proceed if landings columns actually exist in this data frame + if (length(landings_cols_init) > 0) { + # Clean up fleet names and keywords + landings_cols_new <- stringr::str_remove_all( + landings_cols_init, + paste0("_", fleets, collapse = "|") + ) |> stringr::str_replace_all("_", " ") + # Drop "weight" or "number" if present + landings_cols_new <- unique( + stringr::str_remove_all(tolower(landings_cols_new), " number| weight") + ) + # Check if we should simplify to a single "Landings" label + if (length(unique(landings_cols_new)) == 2) { + matches <- sapply(uncert_lab, function(l) { + any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) + }) + id_uncert <- uncert_lab[matches] + landings_cols_new <- c(paste0("Landings (", unit_label, ") (", id_uncert, ")"), id_uncert) + # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column + } + + # Add units + # landings_cols_new <- paste0(landings_cols_new, " (", unit_label, ")") + + # Re-attach fleet names to the new labels + cols_fleets <- stringr::str_extract( + landings_cols_init, + paste0("_",fleets, "$", collapse = "|") + ) |> stringr::str_remove_all("_") + + # Final target labels + final_names <- paste0(landings_cols_new, " - ", cols_fleets) + + # Create a named vector for renaming: c(new_name = old_name) + # This handles the "Rename this specific old name to this specific new name" + rename_map <- setNames(landings_cols_init, final_names) + + # Apply the renaming + table_data <- table_data |> + dplyr::rename(any_of(rename_map)) + + # Comment out from here to closing brackets if don't want to combine label and uncertainty + # {{ ------------------------------------------------------------------- + # Use loop to combine label (uncertainty) + landings_cols <- grep(paste0("Landings \\(", unit_label, "\\)"), names(table_data), value = TRUE) + + for (l_col in landings_cols) { + # 1. Extract fleet from current landing column name + f_id <- stringr::str_extract(l_col, paste0(unique(cols_fleets), collapse = "|")) + + # 2. Construct the matching uncertainty column name + u_col <- paste0(id_uncert, " - ", f_id) + + # 3. Only perform the merge if the uncertainty column actually exists + if (u_col %in% names(table_data)) { + table_data[[l_col]] <- paste0( + table_data[[l_col]], + " (", table_data[[u_col]], ")" + ) + + # Optional: Clean up " (NA)" if they appear + table_data[[l_col]] <- stringr::str_remove(table_data[[l_col]], " \\(NA\\)") + } + } + # Remove error column(s) + table_data <- table_data |> + dplyr::select(-dplyr::matches(paste0(uncert_lab, " - ", fleets, collapse = "|"))) + # }} ------------------------------------------------------------------- } - # Add unit label to landings colnames - landings_cols_new <- paste0( - landings_cols_new, - " (", unit_label, ")") - # Extract fleets from landings_cols_init - cols_fleets <- unlist(stringr::str_extract_all( - landings_cols_init, - paste0(fleets, collapse = "|") - )) - landings_cols_new <- paste0(landings_cols_new, " - ", cols_fleets) - final_df <- table_data |> - # replace col names from unique(prepared_data2$label) with landings_colname - dplyr::rename_with( - ~ gsub(stringr::str_to_title(target_label), landings_colname, .) - ) |> + # Apply the general underscore formatting to ALL columns (regardless of landings) + table_data <- table_data |> dplyr::rename_with(~ gsub("_", " - ", .)) + # Turn df into table - final <- final_df |> + final <- table_data |> gt::gt() |> add_theme() } - # - # if (!is.data.frame(table_data)) { - # table_data <- lapply(table_data, function(df) { - # df |> - # dplyr::rename_with( - # ~ gsub(stringr::str_to_title(target_label), landings_colname, .) - # ) |> - # dplyr::rename_with(~ gsub("_", " - ", .)) - # }) - # final <- lapply(table_data, function(df) { - # df |> - # gt::gt() |> - # add_theme() - # }) - # } else { - # # Determine target label(s) for landings based on available labels in data - # # If 1 label -> "Landings" - # # if > 1 label -> drop "weight" or "number" if present - # landings_cols_init <- colnames(table_data)[ - # grepl("landings", tolower(colnames(table_data))) - # ] - # landings_cols_new <- stringr::str_remove_all( - # landings_cols_init, - # paste0("_", fleets,collapse = "|")) - # # drop "weight" or "number" if present - # # Potential for users to want both? - # landings_cols_new <- unique( - # stringr::str_remove_all(landings_cols_new, " Number| Weight")) - # - # # test if all labels are the same in landings_cols - # if (length(unique(landings_cols_new)) == 1) { - # landings_cols_new <- "Landings" - # } - # # Add unit label to landings colnames - # landings_cols_new <- paste0( - # landings_cols_new, - # " (", unit_label, ")") - # # Extract fleets from landings_cols_init - # cols_fleets <- unlist(stringr::str_extract_all( - # landings_cols_init, - # paste0(fleets, collapse = "|") - # )) - # landings_cols_new <- paste0(landings_cols_new, " - ", cols_fleets) - # - # final_df <- table_data |> - # # replace col names from unique(prepared_data2$label) with landings_colname - # dplyr::rename_with( - # ~ gsub(stringr::str_to_title(target_label), landings_colname, .) - # ) |> - # dplyr::rename_with(~ gsub("_", " - ", .)) - # - # final <- final_df |> - # gt::gt() |> - # add_theme() - # } - - # final - # Progress: - # for bsb, hake, vsnap, and stockplotr::example_data, cols are: - # "Year", "Landings ()", "uncertainty" - # for am, cols are: - # "Landings (mt) - cbn", "cv - cbn", "Landings (mt) - cbs", "cv - cbs", etc # export figure to rda if argument = T if (make_rda == TRUE) { @@ -267,6 +290,15 @@ table_landings <- function( table_df = final_df ) } - # Return finished table - final + # Send table(s) to viewer + if (!is.data.frame(final)) { + 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_table.R b/R/utils_table.R index 2433cba5..b3473045 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -111,7 +111,10 @@ check_label_differences <- function(dat, index_variables, id_group = NULL) { mod_data <- dplyr::filter(dat, model == mod) mod_id_group <- unique(id_group[names(id_group) == mod]) - if (length(unique(mod_data$label)) == 2) { + 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), From ac43abafb4f0fe091f28da046bbddd356137e22f Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Tue, 13 Jan 2026 13:03:20 -0500 Subject: [PATCH 58/62] changes to issues with NAs in error --- R/table_landings.R | 118 +++++++++++++++++++++++++++++++++------------ 1 file changed, 88 insertions(+), 30 deletions(-) diff --git a/R/table_landings.R b/R/table_landings.R index 99c898bf..98c0414d 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -52,6 +52,11 @@ table_landings <- function( 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)) |> @@ -115,9 +120,11 @@ table_landings <- function( any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) }) id_uncert <- uncert_lab[matches] + if (length(id_uncert) == 0) id_uncert <- "uncertainty" + landings_cols_new <- c( ifelse( - uncert_lab == "uncertainty", + id_uncert == "uncertainty", paste0("Landings (", unit_label, ")"), paste0("Landings (", unit_label, ") (", id_uncert, ")") ), @@ -214,12 +221,30 @@ table_landings <- function( any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) }) id_uncert <- uncert_lab[matches] - landings_cols_new <- c(paste0("Landings (", unit_label, ") (", id_uncert, ")"), id_uncert) - # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column + if (length(id_uncert) == 0) id_uncert <- "uncertainty" + } else { + id_uncert <- uncert_lab } - # Add units - # landings_cols_new <- paste0(landings_cols_new, " (", unit_label, ")") + if (any(grepl("expected|predicted|observed|estimated",landings_cols_new))) { + landings_lab <- stringr::str_to_title(unique(stringr::str_extract( + landings_cols_new, + "landings expected|landings predicted|landings observed|landings estimated") + )) + id_uncert_col <- paste0( + id_uncert, " ", landings_lab) + } else { + landings_lab <- "Landings" + } + + if (id_uncert == "uncertainty" || length(id_uncert) == 0) { + landings_cols_new <- c(paste0(landings_lab, " (", unit_label, ")"), id_uncert) + } else { + landings_cols_new <- c( + paste0(landings_lab, " (", unit_label, ") (", id_uncert, ")"), + id_uncert_col) + } + # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column # Re-attach fleet names to the new labels cols_fleets <- stringr::str_extract( @@ -228,7 +253,11 @@ table_landings <- function( ) |> stringr::str_remove_all("_") # Final target labels - final_names <- paste0(landings_cols_new, " - ", cols_fleets) + final_names <- ifelse( + is.na(cols_fleets), + landings_cols_new, + paste0(landings_cols_new, " - ", cols_fleets) + ) # Create a named vector for renaming: c(new_name = old_name) # This handles the "Rename this specific old name to this specific new name" @@ -239,37 +268,66 @@ table_landings <- function( dplyr::rename(any_of(rename_map)) # Comment out from here to closing brackets if don't want to combine label and uncertainty - # {{ ------------------------------------------------------------------- - # Use loop to combine label (uncertainty) - landings_cols <- grep(paste0("Landings \\(", unit_label, "\\)"), names(table_data), value = TRUE) - - for (l_col in landings_cols) { - # 1. Extract fleet from current landing column name - f_id <- stringr::str_extract(l_col, paste0(unique(cols_fleets), collapse = "|")) - - # 2. Construct the matching uncertainty column name - u_col <- paste0(id_uncert, " - ", f_id) + # {{ -------------------------------------------------------------------- + if (!all(is.na(table_data[[id_uncert]]))) { # only works for 1 column of uncertainty data + # Use loop to combine label (uncertainty) + landings_cols <- grep(paste0("Landings.*\\(", unit_label, "\\)"), names(table_data), value = TRUE) - # 3. Only perform the merge if the uncertainty column actually exists - if (u_col %in% names(table_data)) { - table_data[[l_col]] <- paste0( - table_data[[l_col]], - " (", table_data[[u_col]], ")" - ) + for (col_name in landings_cols) { + # 2. Extract metadata from the current column name + # Example: "land exp (mt) (cv) - mrip" -> Type: exp, Fleet: mrip + type_val <- stringr::str_extract(col_name, "Expected|Predicted|Observed|Estimated") + fleet_val <- stringr::str_extract(col_name, glue::glue("{unique(cols_fleets)}$")) # Use your specific fleet list - # Optional: Clean up " (NA)" if they appear - table_data[[l_col]] <- stringr::str_remove(table_data[[l_col]], " \\(NA\\)") + # 3. Construct the name of the "CV" column that matches + # This looks for the column starting with "cv", containing the type and the fleet + cv_col_name <- names(table_data)[ + stringr::str_detect(names(table_data), glue::glue("^{id_uncert}")) & + stringr::str_detect(names(table_data), type_val) & + stringr::str_detect(names(table_data), na.omit(fleet_val)) + ] + + # 4. Update the Landings column with the combined format + # If a matching CV column was found, merge them + if (length(cv_col_name) == 1) { + table_data[[col_name]] <- paste0( + table_data[[col_name]], " (", table_data[[cv_col_name]], ")" + ) + } + } + + if (length(landings_cols) > 1) { + for (l_col in landings_cols) { + # 1. Extract fleet from current landing column name + f_id <- stringr::str_extract(l_col, paste0(unique(cols_fleets), collapse = "|")) + + # 2. Construct the matching uncertainty column name + u_col <- paste0(id_uncert, " - ", f_id) + + # 3. Only perform the merge if the uncertainty column actually exists + if (u_col %in% names(table_data)) { + table_data[[l_col]] <- paste0( + table_data[[l_col]], + " (", table_data[[u_col]], ")" + ) + + # Optional: Clean up " (NA)" if they appear + table_data[[l_col]] <- stringr::str_remove(table_data[[l_col]], " \\(NA\\)") + } + } + # Remove error column(s) + table_data <- table_data |> + dplyr::select(-dplyr::matches(paste0(uncert_lab, " - ", fleets, collapse = "|"))) } } - # Remove error column(s) - table_data <- table_data |> - dplyr::select(-dplyr::matches(paste0(uncert_lab, " - ", fleets, collapse = "|"))) - # }} ------------------------------------------------------------------- + # }} --------------------------------------------------------------------- } # Apply the general underscore formatting to ALL columns (regardless of landings) table_data <- table_data |> - dplyr::rename_with(~ gsub("_", " - ", .)) + dplyr::rename_with(~ gsub("_", " - ", .)) |> + # Remove columns containing all NA + dplyr::select(where(~!all(is.na(.)))) # Turn df into table final <- table_data |> @@ -291,7 +349,7 @@ table_landings <- function( ) } # Send table(s) to viewer - if (!is.data.frame(final)) { + if (!is.data.frame(table_data)) { for(t in final) { print(t) } From e68fe492cff2ae6ecd8e5603a210064681de0881 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 23 Jan 2026 09:10:38 -0500 Subject: [PATCH 59/62] Address bug found in #179 (#180) * fix bug in ss3 conversion where age selex has wrong headers * make note of todo related to this hotfix --- R/convert_output.R | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/R/convert_output.R b/R/convert_output.R index b556b724..a31f7caf 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -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 From 7c0a83c6e4ae28746df6f2fcb066a98db1c211ff Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 23 Jan 2026 10:19:19 -0500 Subject: [PATCH 60/62] Format tables to merge error to estimates (#181) * begin to fix landings table where the error and value labels are combined * finish merge_error fxn and incorporate into table_landings * add documentation to merge_error fxn and remove leftover testing inside fxn * remove statement that changes list to df when only one model * change landings to label in merge_error to make more general for other tables * add condition when only 2 cols and uncert is not there * move merge_error into table utils * update documentation * add flextable back in since it's referenced in add_theme function --- DESCRIPTION | 1 + R/process_data.R | 6 +- R/table_landings.R | 256 ++------------------------- R/utils_table.R | 143 +++++++++++++++ man/check_label_differences.Rd | 16 ++ man/create_rda.Rd | 6 +- man/merge_error.Rd | 29 +++ man/process_table.Rd | 4 +- man/table_landings.Rd | 12 +- tests/testthat/test-table_landings.R | 110 +++++++----- 10 files changed, 282 insertions(+), 301 deletions(-) create mode 100644 man/check_label_differences.Rd create mode 100644 man/merge_error.Rd diff --git a/DESCRIPTION b/DESCRIPTION index bc8c1a2f..fe447551 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,6 +37,7 @@ Depends: Imports: cli, dplyr, + flextable, fs, ggplot2, glue, diff --git a/R/process_data.R b/R/process_data.R index 557fb23e..1fd7ebb6 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -502,9 +502,9 @@ process_table <- function( } # close loop # check if only one model -- export as df instead - if (length(table_list) == 1){ - table_list <- table_list[[1]] - } + # if (length(table_list) == 1){ + # table_list <- table_list[[1]] + # } # Export as list list( diff --git a/R/table_landings.R b/R/table_landings.R index 98c0414d..fbc32a42 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -33,7 +33,6 @@ table_landings <- function( group = NULL, method = "sum", module = NULL, - scale_amount = 1, label = NULL, make_rda = FALSE, tables_dir = getwd()) { @@ -46,7 +45,7 @@ table_landings <- function( geom = "line", era = era, module = module, - scale_amount = scale_amount, + scale_amount = 1, interactive = interactive ) |> dplyr::mutate(estimate = round(as.numeric(estimate), digits = 0)) |> @@ -61,7 +60,7 @@ table_landings <- function( uncert_lab <- prepared_data |> dplyr::filter(!is.na(uncertainty_label)) |> dplyr::group_by(model) |> - dplyr::summarise(unique_uncert = unique(uncertainty_label)) + dplyr::reframe(unique_uncert = unique(uncertainty_label)) # changed to reframe -- may cause errors uncert_lab <- setNames(uncert_lab$unique_uncert, uncert_lab$model) # if (length(unique(uncert_lab)) == 1) uncert_lab <- unique(uncert_lab) # might need this line @@ -94,246 +93,21 @@ table_landings <- function( # 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) - # TODO: TEST !!! - if (!is.data.frame(table_data)) { - # lapply made with the help of Gemini (all recoding names code is original) - df_list <- lapply(table_data, function(tab_dat) { - - landings_cols_init <- colnames(tab_dat)[ - grepl("landings", tolower(colnames(tab_dat))) - ] - - # CONDITION: Only proceed if landings columns actually exist in this data frame - if (length(landings_cols_init) > 0) { - # Clean up fleet names and keywords - landings_cols_new <- stringr::str_remove_all( - landings_cols_init, - paste0("_", fleets, collapse = "|") - ) |> stringr::str_replace_all("_", " ") - # Drop "weight" or "number" if present - landings_cols_new <- unique( - stringr::str_remove_all(tolower(landings_cols_new), " number| weight") - ) - # Check if we should simplify to a single "Landings" label - if (length(unique(landings_cols_new)) == 2) { - matches <- sapply(uncert_lab, function(l) { - any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) - }) - id_uncert <- uncert_lab[matches] - if (length(id_uncert) == 0) id_uncert <- "uncertainty" - - landings_cols_new <- c( - ifelse( - id_uncert == "uncertainty", - paste0("Landings (", unit_label, ")"), - paste0("Landings (", unit_label, ") (", id_uncert, ")") - ), - id_uncert) - # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column - } + # merge error and landings columns and rename + df_list <- merge_error( + table_data, + uncert_lab, + fleets, + label = "landings", + unit_label + ) - # Add units - # landings_cols_new <- paste0(landings_cols_new, " (", unit_label, ")") - - # Re-attach fleet names to the new labels - cols_fleets <- stringr::str_extract( - landings_cols_init, - paste0("_",fleets, "$", collapse = "|") - ) |> stringr::str_remove_all("_") - - # Final target labels - final_names <- ifelse( - is.na(cols_fleets), - landings_cols_new, - paste0(landings_cols_new, " - ", cols_fleets) - ) - - # Create a named vector for renaming: c(new_name = old_name) - # This handles the "Rename this specific old name to this specific new name" - rename_map <- setNames(landings_cols_init, final_names) - - # Apply the renaming - tab_dat <- tab_dat |> - dplyr::rename(any_of(rename_map)) - - # Comment out from here to closing brackets if don't want to combine label and uncertainty - # {{ ------------------------------------------------------------------- - # Use loop to combine label (uncertainty) - landings_cols <- grep(paste0("Landings \\(", unit_label, "\\)"), names(tab_dat), value = TRUE) - - for (l_col in landings_cols) { - # 1. Extract fleet from current landing column name - f_id <- stringr::str_extract(l_col, paste0(unique(cols_fleets), collapse = "|")) - - # 2. Construct the matching uncertainty column name - u_col <- paste0(id_uncert, " - ", f_id) - - # 3. Only perform the merge if the uncertainty column actually exists - if (u_col %in% names(tab_dat)) { - tab_dat[[l_col]] <- paste0( - tab_dat[[l_col]], - " (", tab_dat[[u_col]], ")" - ) - - # Optional: Clean up " (NA)" if they appear - tab_dat[[l_col]] <- stringr::str_remove(tab_dat[[l_col]], " \\(NA\\)") - } - } - # Remove error column(s) - tab_dat <- tab_dat |> - dplyr::select(-dplyr::matches(paste0(uncert_lab, " - ", fleets, collapse = "|"))) - # }} ------------------------------------------------------------------- - } - - # Apply the general underscore formatting to ALL columns (regardless of landings) - tab_dat <- tab_dat |> - dplyr::rename_with(~ gsub("_", " - ", .)) - return(tab_dat) - }) - # transform dfs into tables - final <- lapply(df_list, function(df) { - df |> - gt::gt() |> - add_theme() - }) - } else { - # Determine target label(s) for landings based on available labels in data - # If 1 label -> "Landings" - # if > 1 label -> drop "weight" or "number" if present - landings_cols_init <- colnames(table_data)[ - grepl("landings", tolower(colnames(table_data))) - ] - - # CONDITION: Only proceed if landings columns actually exist in this data frame - if (length(landings_cols_init) > 0) { - # Clean up fleet names and keywords - landings_cols_new <- stringr::str_remove_all( - landings_cols_init, - paste0("_", fleets, collapse = "|") - ) |> stringr::str_replace_all("_", " ") - # Drop "weight" or "number" if present - landings_cols_new <- unique( - stringr::str_remove_all(tolower(landings_cols_new), " number| weight") - ) - # Check if we should simplify to a single "Landings" label - if (length(unique(landings_cols_new)) == 2) { - matches <- sapply(uncert_lab, function(l) { - any(stringr::str_detect(landings_cols_new, stringr::str_c("\\b", l, "\\b"))) - }) - id_uncert <- uncert_lab[matches] - if (length(id_uncert) == 0) id_uncert <- "uncertainty" - } else { - id_uncert <- uncert_lab - } - - if (any(grepl("expected|predicted|observed|estimated",landings_cols_new))) { - landings_lab <- stringr::str_to_title(unique(stringr::str_extract( - landings_cols_new, - "landings expected|landings predicted|landings observed|landings estimated") - )) - id_uncert_col <- paste0( - id_uncert, " ", landings_lab) - } else { - landings_lab <- "Landings" - } - - if (id_uncert == "uncertainty" || length(id_uncert) == 0) { - landings_cols_new <- c(paste0(landings_lab, " (", unit_label, ")"), id_uncert) - } else { - landings_cols_new <- c( - paste0(landings_lab, " (", unit_label, ") (", id_uncert, ")"), - id_uncert_col) - } - # Remove (", id_uncert, ")" in the above line if we don't want to combine value and error in one column - - # Re-attach fleet names to the new labels - cols_fleets <- stringr::str_extract( - landings_cols_init, - paste0("_",fleets, "$", collapse = "|") - ) |> stringr::str_remove_all("_") - - # Final target labels - final_names <- ifelse( - is.na(cols_fleets), - landings_cols_new, - paste0(landings_cols_new, " - ", cols_fleets) - ) - - # Create a named vector for renaming: c(new_name = old_name) - # This handles the "Rename this specific old name to this specific new name" - rename_map <- setNames(landings_cols_init, final_names) - - # Apply the renaming - table_data <- table_data |> - dplyr::rename(any_of(rename_map)) - - # Comment out from here to closing brackets if don't want to combine label and uncertainty - # {{ -------------------------------------------------------------------- - if (!all(is.na(table_data[[id_uncert]]))) { # only works for 1 column of uncertainty data - # Use loop to combine label (uncertainty) - landings_cols <- grep(paste0("Landings.*\\(", unit_label, "\\)"), names(table_data), value = TRUE) - - for (col_name in landings_cols) { - # 2. Extract metadata from the current column name - # Example: "land exp (mt) (cv) - mrip" -> Type: exp, Fleet: mrip - type_val <- stringr::str_extract(col_name, "Expected|Predicted|Observed|Estimated") - fleet_val <- stringr::str_extract(col_name, glue::glue("{unique(cols_fleets)}$")) # Use your specific fleet list - - # 3. Construct the name of the "CV" column that matches - # This looks for the column starting with "cv", containing the type and the fleet - cv_col_name <- names(table_data)[ - stringr::str_detect(names(table_data), glue::glue("^{id_uncert}")) & - stringr::str_detect(names(table_data), type_val) & - stringr::str_detect(names(table_data), na.omit(fleet_val)) - ] - - # 4. Update the Landings column with the combined format - # If a matching CV column was found, merge them - if (length(cv_col_name) == 1) { - table_data[[col_name]] <- paste0( - table_data[[col_name]], " (", table_data[[cv_col_name]], ")" - ) - } - } - - if (length(landings_cols) > 1) { - for (l_col in landings_cols) { - # 1. Extract fleet from current landing column name - f_id <- stringr::str_extract(l_col, paste0(unique(cols_fleets), collapse = "|")) - - # 2. Construct the matching uncertainty column name - u_col <- paste0(id_uncert, " - ", f_id) - - # 3. Only perform the merge if the uncertainty column actually exists - if (u_col %in% names(table_data)) { - table_data[[l_col]] <- paste0( - table_data[[l_col]], - " (", table_data[[u_col]], ")" - ) - - # Optional: Clean up " (NA)" if they appear - table_data[[l_col]] <- stringr::str_remove(table_data[[l_col]], " \\(NA\\)") - } - } - # Remove error column(s) - table_data <- table_data |> - dplyr::select(-dplyr::matches(paste0(uncert_lab, " - ", fleets, collapse = "|"))) - } - } - # }} --------------------------------------------------------------------- - } - - # Apply the general underscore formatting to ALL columns (regardless of landings) - table_data <- table_data |> - dplyr::rename_with(~ gsub("_", " - ", .)) |> - # Remove columns containing all NA - dplyr::select(where(~!all(is.na(.)))) - - # Turn df into table - final <- table_data |> + # 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) { @@ -343,7 +117,7 @@ table_landings <- function( fig_or_table = "table", dat = dat, dir = tables_dir, - scale_amount = scale_amount, + scale_amount = 1, unit_label = unit_label, table_df = final_df ) diff --git a/R/utils_table.R b/R/utils_table.R index b3473045..d63f73c3 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -170,3 +170,146 @@ check_label_differences <- function(dat, index_variables, id_group = NULL) { } 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 <- setNames(label_cols_init, final_names) + + # rename cols for final df + rename_map_final <- 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(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/man/check_label_differences.Rd b/man/check_label_differences.Rd new file mode 100644 index 00000000..d11db3b8 --- /dev/null +++ b/man/check_label_differences.Rd @@ -0,0 +1,16 @@ +% 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} +} +\description{ +Create loop to test for differences in column values +} 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/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/process_table.Rd b/man/process_table.Rd index d2e5b5e7..8e9b31c1 100644 --- a/man/process_table.Rd +++ b/man/process_table.Rd @@ -4,7 +4,7 @@ \alias{process_table} \title{Processing for tables} \usage{ -process_table(dat, group = NULL, method = "sum") +process_table(dat, group = NULL, method = "sum", label = NULL) } \arguments{ \item{dat}{Pre-filtered data from \link[stockplotr]{filter_data} following a @@ -15,6 +15,8 @@ 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}. diff --git a/man/table_landings.Rd b/man/table_landings.Rd index de4145b6..b7bdff21 100644 --- a/man/table_landings.Rd +++ b/man/table_landings.Rd @@ -7,12 +7,11 @@ table_landings( dat, unit_label = "mt", - era = "time", + era = NULL, interactive = TRUE, group = NULL, method = "sum", module = NULL, - scale_amount = 1, label = NULL, make_rda = FALSE, tables_dir = getwd() @@ -43,11 +42,10 @@ is set to "none". Options are "sum" or "mean". Default is "sum".} 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{scale_amount}{A number describing how much to scale down the quantities -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{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{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, 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() + ) + ) +}) From 67fdbfaef9069ac784e626089da9d556ba24a3e8 Mon Sep 17 00:00:00 2001 From: Sam Schiano <125507018+Schiano-NOAA@users.noreply.github.com> Date: Fri, 23 Jan 2026 14:32:43 -0500 Subject: [PATCH 61/62] fix fxns and update documentation --- R/plot_recruitment.R | 2 +- R/process_data.R | 4 ++-- R/save_all_plots.R | 8 ++++---- R/table_landings.R | 2 +- R/utils_plot.R | 1 - R/utils_table.R | 9 +++++---- man/check_label_differences.Rd | 2 ++ man/plot_recruitment.Rd | 2 +- man/plot_timeseries.Rd | 2 -- 9 files changed, 16 insertions(+), 16 deletions(-) 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 1fd7ebb6..1d0d3783 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -463,7 +463,7 @@ process_table <- function( if (length(mod_uncert_lab) == 1 && is.na(mod_uncert_lab)) { mod_uncert_lab <- "Uncertainty" } else { - uncert_lab <- na.omit(uncert_lab) + uncert_lab <- stats::a.omit(uncert_lab) } table_data <- mod_dat |> @@ -490,7 +490,7 @@ process_table <- function( 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(contains(f), .after = last_col()) + dplyr::relocate(dplyr::contains(f), .after = dplyr::last_col()) } } table_list[[mod]] <- table_data diff --git a/R/save_all_plots.R b/R/save_all_plots.R index 93b208f1..0c9eb348 100644 --- a/R/save_all_plots.R +++ b/R/save_all_plots.R @@ -71,7 +71,7 @@ save_all_plots <- function( # imported from plot_landings landings_unit_label = "mt", # imported from plot_recruitment_deviations- zero unique arguments - # imported from plot_spawn_recruitment + # imported from plot_stock_recruitment spawning_biomass_label = "mt", spawning_biomass_scale_amount = 1, # imported from plot_spawning_biomass @@ -231,8 +231,8 @@ save_all_plots <- function( tryCatch( { - cli::cli_h2("plot_spawn_recruitment") - plot_spawn_recruitment(dat, + cli::cli_h2("plot_stock_recruitment") + plot_stock_recruitment(dat, spawning_biomass_label, recruitment_label = recruitment_unit_label, make_rda = TRUE, @@ -242,7 +242,7 @@ save_all_plots <- function( # |> suppressWarnings() |> invisible() }, error = function(e) { - cli::cli_alert_danger("plot_spawn_recruitment failed to run.") + 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}") diff --git a/R/table_landings.R b/R/table_landings.R index fbc32a42..efa714ce 100644 --- a/R/table_landings.R +++ b/R/table_landings.R @@ -61,7 +61,7 @@ table_landings <- function( 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 <- setNames(uncert_lab$unique_uncert, uncert_lab$model) + 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 diff --git a/R/utils_plot.R b/R/utils_plot.R index c98edd55..bd276c4f 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -199,7 +199,6 @@ 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 #' #' diff --git a/R/utils_table.R b/R/utils_table.R index d63f73c3..ce6502da 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -103,6 +103,7 @@ create_latex_table <- function(data, #' 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 @@ -142,7 +143,7 @@ check_label_differences <- function(dat, index_variables, id_group = NULL) { # 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(across(unique(mod_data$label), ~ all(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 @@ -253,10 +254,10 @@ merge_error <- function(table_data, uncert_lab, fleets, label, unit_label) { ) # Assign previous names with new identifying ones - rename_map <- setNames(label_cols_init, final_names) + rename_map <- stats::setNames(label_cols_init, final_names) # rename cols for final df - rename_map_final <- setNames( + rename_map_final <- stats::setNames( final_names, ifelse( is.na(cols_fleets), @@ -266,7 +267,7 @@ merge_error <- function(table_data, uncert_lab, fleets, label, unit_label) { # Apply the renaming tab_dat <- tab_dat |> - dplyr::rename(any_of(rename_map)) + 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)))] diff --git a/man/check_label_differences.Rd b/man/check_label_differences.Rd index d11db3b8..06dc1dfc 100644 --- a/man/check_label_differences.Rd +++ b/man/check_label_differences.Rd @@ -10,6 +10,8 @@ check_label_differences(dat, index_variables, id_group = NULL) \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/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 b7e734a1..405ddf80 100644 --- a/man/plot_timeseries.Rd +++ b/man/plot_timeseries.Rd @@ -53,8 +53,6 @@ of `y`.} (e.g. "year", "area", etc.)} \item{...}{inherited arguments from internal functions from ggplot2::geom_xx} - -\item{hline}{indicate true or false to place a horizontal line at 1} } \value{ Create a time series plot for a stock assessment report. The user From 88c5ef71ee9cc50f26a85f2eb4181b4792752d41 Mon Sep 17 00:00:00 2001 From: sbreitbart-NOAA Date: Fri, 23 Jan 2026 14:44:31 -0500 Subject: [PATCH 62/62] Fix typo --- R/process_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/process_data.R b/R/process_data.R index 1d0d3783..0f475b39 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -463,7 +463,7 @@ process_table <- function( if (length(mod_uncert_lab) == 1 && is.na(mod_uncert_lab)) { mod_uncert_lab <- "Uncertainty" } else { - uncert_lab <- stats::a.omit(uncert_lab) + uncert_lab <- stats::na.omit(uncert_lab) } table_data <- mod_dat |>