diff --git a/R/convert_output.R b/R/convert_output.R index 8ba3f2cc..65ee3601 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -102,12 +102,15 @@ convert_output <- function( if (is.character(file)) { url_pattern <- "^(https?|ftp|file):\\/\\/[-A-Za-z0-9+&@#\\/%?=~_|!:,.;]*[-A-Za-z0-9+&@#\\/%=~_|]$" if (grepl(url_pattern, file)) { - check <- tryCatch({ - headers <- curlGetHeaders(file) - attributes(headers)[["status"]] - }, error = function(e) { - 404 - }) + check <- tryCatch( + { + headers <- curlGetHeaders(file) + attributes(headers)[["status"]] + }, + error = function(e) { + 404 + } + ) if (check == 404) cli::cli_abort(c(message = "Invalid URL.")) } else { if (!file.exists(file)) { @@ -182,7 +185,7 @@ convert_output <- function( if (vers < 3.3) { cli::cli_abort("This function in its current state can not process the data.") } - + # Extract fleet names if (is.null(fleet_names)) { fleet_names <- SS3_extract_fleet(dat, vers) @@ -190,7 +193,7 @@ convert_output <- function( # Output fleet names in console cli::cli_alert_info("Identified fleet names:") cli::cli_alert_info("{fleet_names}") - + # Estimated and focal parameters to put into reformatted output df - naming conventions from SS3 # Extract keywords from ss3 file # Find row where keywords start @@ -210,7 +213,7 @@ convert_output <- function( # identify first reported keyword keywords_end_row <- which(apply(dat, 1, function(row) any(grepl(keyword_1, row))))[2] - 12 # 12 rows behind is the last entry for keywords # always extract the second entry bc the first is just in the list of keywords - + keywords <- dat[keywords_start_row:keywords_end_row, ][-c(1:3), c(1:3)] |> replace_empty_with_na_all() keywords <- Filter(function(x) !all(is.na(x)), keywords) @@ -219,7 +222,7 @@ convert_output <- function( dplyr::mutate(output_order = as.numeric(stringr::str_extract(output_order, "\\d+$"))) |> dplyr::filter(output == "Y") |> dplyr::pull(keyword) - + # Group parameters base on table pattern std <- c( "DERIVED_QUANTITIES", @@ -286,9 +289,9 @@ convert_output <- function( # Output fleet names in console cli::cli_alert_info("Identified fleet names:") cli::cli_alert_info("{fleet_names}") - + param_names <- names(dat) - + std <- c( "recruit", # STD "exploitation", # STD @@ -297,7 +300,7 @@ convert_output <- function( "discard", # STD "kobe", # maybe STD "cpue", # STD - "derived_quants", #STD + "derived_quants", # STD "Dynamic_Bzero", # STD "len_comp_fit_table", # STD "age_comp_fit_table" # STD @@ -306,7 +309,7 @@ convert_output <- function( "SPAWN_RECRUIT_CURVE", # RAND "sprseries", # RAND "parameters" # RAND - # "equil_yeild", # SKIP FOR NOW - RAND + # "equil_yeild", # SKIP FOR NOW - RAND ) aa.al <- c( "sizeselex", # AA.AL @@ -324,8 +327,8 @@ convert_output <- function( "Z_by_area", # AA.AL "M_by_area" # AA.AL ) - # "growth_series" # ? UNSURE THIS IS NULL IN EXAMPLE - # "mngwt" # ??? + # "growth_series" # ? UNSURE THIS IS NULL IN EXAMPLE + # "mngwt" # ??? single_val <- c( "sprtarg", # single value "btarg", # single value @@ -336,10 +339,10 @@ convert_output <- function( cha <- c() info <- c() } - + # Extract units - - + + # Loop for all identified parameters to extract for plotting and use # Create list of parameters that were not found in the output file # 1,4,10,17,19,20,22,32,37 @@ -354,14 +357,14 @@ convert_output <- function( "settlement", "birthseas", "count", "kind" ) - + errors <- c( "StdDev", "sd", "std", "stddev", "se", "SE", "cv", "CV" # "dev" # not included bc this is dev in model, not uncertainty of the value ) - + miss_parms <- c() out_list <- list() #### SS3 loop #### @@ -369,13 +372,13 @@ convert_output <- function( # Processing data frame parm_sel <- param_names[i] if (parm_sel %in% c(std, std2, cha, rand, aa.al, single_val)) { - cli::cli_alert(glue::glue("Processing {parm_sel}")) # Remove [{i}] - if(is.character(file)) { + cli::cli_alert(glue::glue("Processing {parm_sel}")) # Remove [{i}] + if (is.character(file)) { extract <- SS3_extract_df(dat, parm_sel) } else { extract <- file[[parm_sel]] } - + if (!is.data.frame(extract)) { if (is.numeric(extract)) { df <- data.frame( @@ -433,7 +436,6 @@ convert_output <- function( df3 <- df3 |> dplyr::rename(!!col_name := i) } - } } # Remove any leftover NA columns if still present @@ -465,7 +467,7 @@ convert_output <- function( } else if (any(colnames(df3) %in% c(factors, errors))) { # Keeping check here if case arises that there is a similar situation to the error # aka there are multiple columns containing the string and they are not selected properly - + if ("sexes" %in% colnames(df3)) { df3 <- df3 |> # add in case if sexes is present and add sex as na if so @@ -479,7 +481,7 @@ convert_output <- function( } else { df3 <- dplyr::mutate(df3, sex = NA) } - + # Identify which errors were identified in a column & rename err_col_id <- colnames(df3)[grepl(paste0(errors, "$", collapse = "|"), colnames(df3))] # rename error column @@ -545,15 +547,15 @@ convert_output <- function( TRUE ~ NA ), month = if ("month" %in% colnames(df3)) { - month - } else { - dplyr::case_when( - grepl("_month_[0-9]+$", label) ~ stringr::str_extract(label, "(?<=month_)[0-9]+$"), - TRUE ~ ifelse(any(grepl("^month$", colnames(df3))), month, NA) # this might remove month - ) - } + month + } else { + dplyr::case_when( + grepl("_month_[0-9]+$", label) ~ stringr::str_extract(label, "(?<=month_)[0-9]+$"), + TRUE ~ ifelse(any(grepl("^month$", colnames(df3))), month, NA) # this might remove month + ) + } ) - + df4 <- df4 |> dplyr::mutate( label = dplyr::case_when( @@ -568,7 +570,7 @@ convert_output <- function( cli::cli_alert_warning(glue::glue("Data frame not compatible in {parm_sel}.")) } if (any(colnames(df4) %in% c("value"))) df4 <- dplyr::rename(df4, estimate = value) - + # Check if error values are in the labels column and extract out if (any(sapply(paste0("(^|[_.])", errors, "($|[_.])"), function(x) grepl(x, unique(df4$label))))) { err_names <- unique(df4$label)[grepl(paste(paste0("(^|[_.])", errors, "($|[_.])"), collapse = "|"), unique(df4$label)) & !unique(df4$label) %in% errors] @@ -647,7 +649,7 @@ convert_output <- function( } } } - + df5 <- df4 |> dplyr::select(tidyselect::any_of(c("label", "estimate", "year", factors, errors))) |> dplyr::mutate( @@ -657,7 +659,7 @@ convert_output <- function( TRUE ~ label ) ) - + if (any(colnames(df5) %in% errors)) { df5 <- df5 |> dplyr::mutate(uncertainty_label = intersect(names(df5), errors)) |> @@ -672,11 +674,11 @@ convert_output <- function( colnames(df5) <- tolower(names(df5)) } if ("seas" %in% colnames(df5)) df5 <- dplyr::rename(df5, season = seas) - + if ("subseas" %in% colnames(df5)) df5 <- dplyr::rename(df5, subseason = subseas) - + if ("like" %in% colnames(df5)) df5 <- dplyr::rename(df5, likelihood = like) - + df5[setdiff(tolower(names(out_new)), tolower(names(df5)))] <- NA if (ncol(out_new) < ncol(df5)) { diff <- setdiff(names(df5), names(out_new)) @@ -776,7 +778,7 @@ convert_output <- function( # Add to new dataframe df5 <- Reduce(rbind, comps_list) out_list[[parm_sel]] <- df5 - + ##### cha #### } else if (parm_sel %in% cha) { # Only one keyword characterized as this @@ -820,7 +822,7 @@ convert_output <- function( # "SPAWN_RECR_CURVE" # "Biology_at_age_in_endyr" # "PARAMETERS" - + if (parm_sel %in% c("SPAWN_RECR_CURVE", "SPAWN_RECRUIT_CURVE")) { # 32 # TODO: add this to converter @@ -896,7 +898,7 @@ convert_output <- function( # label = paste("estimate_", label, sep = ""), morph = NA ) - + sub_df2 <- df3[, c(1:2, (actual_col + 1):(moref_col - 1))] |> tidyr::pivot_longer( cols = -c(yr, era), @@ -1192,7 +1194,7 @@ 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 @@ -1206,10 +1208,10 @@ convert_output <- function( 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 <- row_match(row, df1) # Subset data frame @@ -1237,26 +1239,27 @@ convert_output <- function( if (label == "f") { label <- "fishing_mortality" } - } else ( - # add conditions for naming label from aa.al - label <- switch( - parm_sel, - # "sizeselex" = "selectivity_length", - "ageselex" = "selectivity_age", - "Natural_Mortality" = "natural_mortality_age", - "fatage" = "fishing_mortality_age", - "natage" = "abundance_age", - "batage" = "biomass_age", - "natlen" = "abundance_length", - "batlen" = "biomass_length", - "discard_at_age" = "discard_age", - "catage" = "catch_age", - "Z_at_age" = "total_mortality_age", - "M_at_age" = "natural_mortality_age", - "Z_by_area" = "total_mortality", - "M_by_area" = "natural_mortality" + } else { + ( + # add conditions for naming label from aa.al + label <- switch(parm_sel, + # "sizeselex" = "selectivity_length", + "ageselex" = "selectivity_age", + "Natural_Mortality" = "natural_mortality_age", + "fatage" = "fishing_mortality_age", + "natage" = "abundance_age", + "batage" = "biomass_age", + "natlen" = "abundance_length", + "batlen" = "biomass_length", + "discard_at_age" = "discard_age", + "catage" = "catch_age", + "Z_at_age" = "total_mortality_age", + "M_at_age" = "natural_mortality_age", + "Z_by_area" = "total_mortality", + "M_by_area" = "natural_mortality" ) - ) + ) + } if (grepl("age", tolower(parm_sel))) { fac <- "age" } else if (any(grepl("length|len", tolower(parm_sel)))) { @@ -1266,10 +1269,10 @@ convert_output <- function( } else { fac <- "age" } - + # remove fac from label if (grepl(glue::glue("_{fac}"), label)) label <- stringr::str_remove(label, glue::glue("_{fac}")) - + # Reformat dataframe if (any(colnames(df3) %in% c("Yr", "yr"))) { df3 <- df3 |> @@ -2337,9 +2340,9 @@ convert_output <- function( # temporarily add call to local csv so I can test # con_file <- glue::glue("~/GitHub/stockplotr/inst/resources/{model}_var_names.csv") var_names_sheet <- utils::read.csv(con_file, na.strings = "") - + if (tolower(model) == "bam") { - var_names_sheet <- var_names_sheet |> + var_names_sheet <- var_names_sheet |> dplyr::mutate(label = tolower(label)) } diff --git a/R/plot_biomass.R b/R/plot_biomass.R index 45dbf3f4..199d793c 100644 --- a/R/plot_biomass.R +++ b/R/plot_biomass.R @@ -84,10 +84,10 @@ plot_biomass <- function( cli::cli_alert_warning("Scale amount is not applicable when relative = TRUE. Resetting scale_amount to 1.") scale_amount <- 1 } - + orig_group <- group orig_facet <- facet - + # Filter data for biomass # TODO: determine method to ID that first point in the timeseries is actually Bunfished ref pt prepared_data <- filter_data( @@ -177,10 +177,14 @@ plot_biomass <- function( ### Make RDA ---- if (make_rda) { if (relative) { - rel.B.min <- calc_kqs(returned_kq = "rel.B.min", - final = final) - rel.B.max <- calc_kqs(returned_kq = "rel.B.max", - final = final) + rel.B.min <- calc_kqs( + returned_kq = "rel.B.min", + final = final + ) + rel.B.max <- calc_kqs( + returned_kq = "rel.B.max", + final = final + ) # calculate & export key quantities export_kqs(rel.B.min, rel.B.max) @@ -188,10 +192,14 @@ plot_biomass <- function( # Add key quantities to captions/alt text insert_kqs(rel.B.min, rel.B.max) } else { - B.min <- calc_kqs(returned_kq = "B.min", - prepared_data = prepared_data) - B.max <- calc_kqs(returned_kq = "B.max", - prepared_data = prepared_data) + B.min <- calc_kqs( + returned_kq = "B.min", + prepared_data = prepared_data + ) + B.max <- calc_kqs( + returned_kq = "B.max", + prepared_data = prepared_data + ) export_kqs(B.min, B.max) insert_kqs(B.min, B.max) @@ -199,41 +207,61 @@ plot_biomass <- function( B.ref.pt <- as.character(ref_line) B.units <- as.character(unit_label) - B.start.year <- calc_kqs(returned_kq = "B.start.year", - prepared_data = prepared_data) - B.end.year <- calc_kqs(returned_kq = "B.end.year", - prepared_data = prepared_data) - B.terminal.year <- calc_kqs(returned_kq = "B.terminal.year", - dat = dat, - relative = relative) + B.start.year <- calc_kqs( + returned_kq = "B.start.year", + prepared_data = prepared_data + ) + B.end.year <- calc_kqs( + returned_kq = "B.end.year", + prepared_data = prepared_data + ) + B.terminal.year <- calc_kqs( + returned_kq = "B.terminal.year", + dat = dat, + relative = relative + ) # SS3, FIMS if ("spawning_biomass_msy" %in% dat$label) { - sb_msy <- calc_kqs(returned_kq = "sb_msy", - dat = dat) - b_sb_msy <- calc_kqs(returned_kq = "b_sb_msy", - dat = dat) - B.msy <- calc_kqs(returned_kq = "B.msy", - dat = dat) + sb_msy <- calc_kqs( + returned_kq = "sb_msy", + dat = dat + ) + b_sb_msy <- calc_kqs( + returned_kq = "b_sb_msy", + dat = dat + ) + B.msy <- calc_kqs( + returned_kq = "B.msy", + dat = dat + ) B.msy.min <- NA B.msy.max <- NA - # BAM + # BAM } else if ("bmsy" %in% dat$label) { - B.msy <- calc_kqs(returned_kq = "B.msy", - dat = dat) - B.msy.min_uncert <- calc_kqs(returned_kq = "B.msy.min_uncert", - dat = dat) - B.msy.min <- calc_kqs(returned_kq = "B.msy.min", - dat = dat) - B.msy.max <- calc_kqs(returned_kq = "B.msy.max", - dat = dat) - # Rceattle + B.msy <- calc_kqs( + returned_kq = "B.msy", + dat = dat + ) + B.msy.min_uncert <- calc_kqs( + returned_kq = "B.msy.min_uncert", + dat = dat + ) + B.msy.min <- calc_kqs( + returned_kq = "B.msy.min", + dat = dat + ) + B.msy.max <- calc_kqs( + returned_kq = "B.msy.max", + dat = dat + ) + # Rceattle } else { B.msy <- NA B.msy.min <- NA B.msy.max <- NA } - + export_kqs( B.ref.pt, B.units, diff --git a/R/plot_fishing_mortality.R b/R/plot_fishing_mortality.R index 56b01401..551b2379 100644 --- a/R/plot_fishing_mortality.R +++ b/R/plot_fishing_mortality.R @@ -87,10 +87,14 @@ plot_fishing_mortality <- function( ### Make RDA ---- if (make_rda) { - F.min <- calc_kqs(returned_kq = "F.min", - prepared_data = prepared_data) - F.max <- calc_kqs(returned_kq = "F.max", - prepared_data = prepared_data) + F.min <- calc_kqs( + returned_kq = "F.min", + prepared_data = prepared_data + ) + F.max <- calc_kqs( + returned_kq = "F.max", + prepared_data = prepared_data + ) export_kqs(F.min, F.max) insert_kqs(F.min, F.max) @@ -98,15 +102,20 @@ plot_fishing_mortality <- function( F.ref.pt <- as.character(ref_line) F.start.year <- min(prepared_data$year) F.end.year <- max(prepared_data$year) - F.terminal.year <- calc_kqs(returned_kq = "F.terminal.year", + F.terminal.year <- calc_kqs( + returned_kq = "F.terminal.year", + dat = dat + ) + + F.target <- calc_kqs( + returned_kq = "F.target", + dat = dat + ) + f.limit <- calc_kqs( + returned_kq = "f.limit", dat = dat ) - - F.target <- calc_kqs(returned_kq = "F.target", - dat = dat) - f.limit <- calc_kqs(returned_kq = "f.limit", - dat = dat) - + export_kqs( F.ref.pt, F.start.year, diff --git a/R/plot_spawning_biomass.R b/R/plot_spawning_biomass.R index 33a67fca..c3cad064 100644 --- a/R/plot_spawning_biomass.R +++ b/R/plot_spawning_biomass.R @@ -242,13 +242,17 @@ plot_spawning_biomass <- function( ### Make RDA ---- if (make_rda) { if (relative) { - rel.ssb.min <- calc_kqs(returned_kq = "rel.ssb.min", - final = final) - - - rel.ssb.max <- calc_kqs(returned_kq = "rel.ssb.max", - final = final) - + rel.ssb.min <- calc_kqs( + returned_kq = "rel.ssb.min", + final = final + ) + + + rel.ssb.max <- calc_kqs( + returned_kq = "rel.ssb.max", + final = final + ) + # calculate & export key quantities export_kqs(rel.ssb.min, rel.ssb.max) diff --git a/R/plot_stock_recruitment.R b/R/plot_stock_recruitment.R index 87db9481..e22a0f4d 100644 --- a/R/plot_stock_recruitment.R +++ b/R/plot_stock_recruitment.R @@ -178,8 +178,10 @@ plot_stock_recruitment <- function( # Make RDA if (make_rda) { # Obtain relevant key quantities for captions/alt text - sr.age.min <- calc_kqs(returned_kq = "sr.age.min", - dat = dat) + sr.age.min <- calc_kqs( + returned_kq = "sr.age.min", + dat = dat + ) sr.ssb.units <- spawning_biomass_label sr.ssb.min <- min(sr$spawning_biomass, na.rm = TRUE) |> round(digits = 3) sr.ssb.max <- max(sr$spawning_biomass, na.rm = TRUE) |> round(digits = 3) diff --git a/R/process_data.R b/R/process_data.R index b503e37e..a31454f0 100644 --- a/R/process_data.R +++ b/R/process_data.R @@ -533,7 +533,7 @@ process_table <- function( dplyr::rename( !!mod_uncert_lab := uncertainty ) |> - # set values to strings to include trailing zeros from rounding and # format large estimate values with commas + # set values to strings to include trailing zeros from rounding and # format large estimate values with commas dplyr::mutate(estimate = formatC(estimate, format = "f", digits = digits, big.mark = ",")) |> tidyr::pivot_wider( id_cols = dplyr::all_of(c(stringr::str_to_title(mod_cols))), diff --git a/R/table_index.R b/R/table_index.R index 26f76fa1..7af8d509 100644 --- a/R/table_index.R +++ b/R/table_index.R @@ -48,18 +48,17 @@ #' ) #' } table_index <- function( - dat, - era = NULL, - interactive = TRUE, - group = NULL, - method = "sum", - module = NULL, - label = NULL, - digits = 2, - make_rda = FALSE, - tables_dir = getwd() - ) { - + dat, + era = NULL, + interactive = TRUE, + group = NULL, + method = "sum", + module = NULL, + label = NULL, + digits = 2, + make_rda = FALSE, + tables_dir = getwd() +) { # TODO: do group and facet need to be uncommented and updated? # Filter data for landings prepared_data <- filter_data( @@ -71,14 +70,16 @@ table_index <- function( scale_amount = 1, interactive = interactive ) |> - dplyr::mutate(estimate = round(as.numeric(estimate), digits = digits), - uncertainty = round(as.numeric(uncertainty), digits = digits)) - + dplyr::mutate( + estimate = round(as.numeric(estimate), digits = digits), + uncertainty = round(as.numeric(uncertainty), digits = digits) + ) + # Add check if there is any data if (nrow(prepared_data) == 0) { cli::cli_abort("No index data found.") } - + # get uncertainty label by model uncert_lab <- prepared_data |> dplyr::filter(!is.na(uncertainty_label)) |> @@ -86,22 +87,22 @@ table_index <- function( dplyr::reframe(unique_uncert = unique(uncertainty_label)) # changed to reframe -- may cause errors uncert_lab <- stats::setNames(uncert_lab$unique_uncert, uncert_lab$model) # if (length(unique(uncert_lab)) == 1) uncert_lab <- unique(uncert_lab) # might need this line - + # This needs to be adjusted when comparing different models and diff error if (length(uncert_lab) > 1 & length(unique(uncert_lab)) == 1 | length(names(uncert_lab)) == 1) { # prepared_data$model # cli::cli_alert_warning("More than one value for uncertainty exists: {uncert_lab}") uncert_lab <- uncert_lab[[1]] # cli::cli_alert_warning("The first value ({uncert_lab}) will be chosen.") } - + if (is.na(uncert_lab)) uncert_lab <- "uncertainty" - + # get fleet names # TODO: change from fleets to id_group AFTER the process data step and adjust throughout the table based on indexing fleets <- unique(prepared_data$fleet) |> # sort numerically even if fleets are 100% characters stringr::str_sort(numeric = TRUE) - + # TODO: fix this so that fleet names aren't removed if, e.g., group = "fleet" table_data_info <- process_table( dat = prepared_data, @@ -113,12 +114,12 @@ table_index <- 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 index column for every error column -- if not remove the error (can keep index) - + # if (uncert_lab != "") uncert_lab <- glue::glue("({uncert_lab})") - + # merge error and index columns and rename df_list <- merge_error( table_data, @@ -126,31 +127,30 @@ table_index <- function( unit_label = "", # should this be CPUE? uncert_lab ) - + # transform dfs into tables final <- lapply(df_list, function(df) { df |> gt::gt() |> theme_table() }) - + # export figure to rda if argument = T if (make_rda == TRUE) { - # Caption contains no key quantities for index table # So, export captions/alt text csv if absent if (!file.exists(fs::path(getwd(), "captions_alt_text.csv"))) { caps_alttext <- utils::read.csv( system.file("resources", "captions_alt_text_template.csv", package = "stockplotr") ) - # export df with captions and alt text to csv - utils::write.csv( - x = caps_alttext, - file = fs::path(getwd(), "captions_alt_text.csv"), - row.names = FALSE - ) + # export df with captions and alt text to csv + utils::write.csv( + x = caps_alttext, + file = fs::path(getwd(), "captions_alt_text.csv"), + row.names = FALSE + ) } - + if (length(df_list) == 1) { create_rda( object = final$label, @@ -168,7 +168,7 @@ table_index <- function( cli::cli_alert_warning("Multiple tables cannot be exported at this time.") cli::cli_alert_info("We are currently developing this feature.") } - + # Send table(s) to viewer if (!is.data.frame(table_data)) { for (t in final) { diff --git a/R/theme_noaa.R b/R/theme_noaa.R index 4cbedaa0..5f3d85ee 100644 --- a/R/theme_noaa.R +++ b/R/theme_noaa.R @@ -1,5 +1,5 @@ #' Add NOAA theming to ggplot2 object -#' +#' #' The palette is from the 'viridis' package, which contains palettes distinguishable by those with color vision deficiency. #' #' @param discrete Logical. TRUE/FALSE; indicate whether the color or fill aesthetic is discrete. diff --git a/R/utils_plot.R b/R/utils_plot.R index 431ea86f..b6f4b139 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -228,22 +228,22 @@ plot_timeseries <- function( # min, max y axis value min_y <- min(dat$estimate, na.rm = TRUE) max_y <- max(dat$estimate, na.rm = TRUE) - + # if both min and max y values are negative, check if the distance to zero is greater than 50% of the span of the y-axis values. If so, set exp_lims to FALSE to avoid expanding the limits to include zero. - if(min_y < 0 & max_y < 0){ + if (min_y < 0 & max_y < 0) { span <- max_y - min_y dist_to_zero <- abs(max_y) - perc_of_plot <- -(max_y-span) + perc_of_plot <- -(max_y - span) cli::cli_alert_info("Estimates are negative.") cli::cli_alert_info("If estimates were log-transformed, please update the y axis label for accuracy.") cli::cli_alert_info("Example: log({ylab})") - if(perc_of_plot > 50){ + if (perc_of_plot > 50) { exp_lims <- FALSE - } + } } - + y_limits <- if (exp_lims) ggplot2::expand_limits(y = 0) else NULL - + # Put together final plot final <- labs + breaks + y_limits + ggplot2::scale_y_continuous( @@ -1075,27 +1075,27 @@ plot_obsvpred <- function( minor.ticks = TRUE ) ) - + exp_lims <- TRUE # min, max y axis value min_y <- min(dat$estimate, na.rm = TRUE) max_y <- max(dat$estimate, na.rm = TRUE) - + # if both min and max y values are negative, check if the distance to zero is greater than 50% of the span of the y-axis values. If so, set exp_lims to FALSE to avoid expanding the limits to include zero. - if(min_y < 0 & max_y < 0){ + if (min_y < 0 & max_y < 0) { span <- max_y - min_y dist_to_zero <- abs(max_y) - perc_of_plot <- -(max_y-span) + perc_of_plot <- -(max_y - span) cli::cli_alert_info("Estimates are negative.") cli::cli_alert_info("If estimates were log-transformed, please update the y axis label for accuracy.") cli::cli_alert_info("Example: log({ylab})") - if(perc_of_plot > 50){ + if (perc_of_plot > 50) { exp_lims <- FALSE - } + } } - + y_limits <- if (exp_lims) ggplot2::expand_limits(y = 0) else NULL - + # Put together final plot final <- labs + breaks + y_limits + diff --git a/R/utils_rda.R b/R/utils_rda.R index a5b84d2c..7caf02ca 100644 --- a/R/utils_rda.R +++ b/R/utils_rda.R @@ -3,30 +3,28 @@ # @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ #' Calculate key quantities -#' +#' #' @param returned_kq String. Key quantity to be returned. #' @param prepared_data Data frame. The prepared_data object. #' @param dat Data frame. The original data object. #' @param final ggplot2 object. The final figure. #' @param relative Logical. TRUE/FALSE; specify whether to set y-axis values relative to the ref_line value. #' @param ... Additional arguments to be passed to the function. -#' +#' #' @return The value of the specified key quantity. -#' +#' #' @examples \dontrun{ #' calc_kqs( #' returned_kq = "F.min", #' dat = dat #' ) #' } - calc_kqs <- function(returned_kq, prepared_data = NULL, dat = NULL, final = NULL, relative = NULL, - ...){ - + ...) { # plot_stock_recruitment()----- if (returned_kq == "sr.age.min") { return( @@ -37,7 +35,7 @@ calc_kqs <- function(returned_kq, as.numeric() ) } - + # plot_spawning_biomass()----- if (returned_kq == "rel.ssb.min") { return( @@ -48,7 +46,7 @@ calc_kqs <- function(returned_kq, round(digits = 2) ) } - + if (returned_kq == "rel.ssb.max") { return( ggplot2::ggplot_build(final)[["data"]][[2]] |> @@ -58,7 +56,7 @@ calc_kqs <- function(returned_kq, round(digits = 2) ) } - + # plot_biomass()----- if (returned_kq == "rel.B.min") { return( @@ -68,7 +66,7 @@ calc_kqs <- function(returned_kq, min() ) } - + if (returned_kq == "rel.B.max") { return( ggplot2::ggplot_build(final)[["data"]][[2]] |> @@ -77,23 +75,23 @@ calc_kqs <- function(returned_kq, max() ) } - + if (returned_kq == "B.min") { return(min(prepared_data$estimate)) } - + if (returned_kq == "B.max") { return(max(prepared_data$estimate)) } - + if (returned_kq == "B.start.year") { return(min(prepared_data$year) |> round(digits = 3)) } - + if (returned_kq == "B.end.year") { return(max(prepared_data$year) |> round(digits = 3)) } - + if (returned_kq == "B.terminal.year") { return( filter_data( @@ -112,7 +110,7 @@ calc_kqs <- function(returned_kq, unique() ) } - + if (returned_kq == "sb_msy") { return( dat |> @@ -121,7 +119,7 @@ calc_kqs <- function(returned_kq, as.numeric() ) } - + if (returned_kq == "b_sb_msy") { return( dat |> @@ -130,7 +128,7 @@ calc_kqs <- function(returned_kq, as.numeric() ) } - + if (returned_kq == "B.msy") { if ("spawning_biomass_msy" %in% dat$label) { sb_msy <- dat |> @@ -151,7 +149,7 @@ calc_kqs <- function(returned_kq, ) } } - + if (returned_kq == "B.msy.min_uncert") { return( dat |> @@ -160,19 +158,31 @@ calc_kqs <- function(returned_kq, as.numeric() ) } - + if (returned_kq == "B.msy.min") { - B.msy <- dat |> dplyr::filter(label == "bmsy") |> dplyr::select(estimate) |> as.numeric() - B.msy.min_uncert <- dat |> dplyr::filter(label == "bmsy") |> dplyr::select(uncertainty) |> as.numeric() + B.msy <- dat |> + dplyr::filter(label == "bmsy") |> + dplyr::select(estimate) |> + as.numeric() + B.msy.min_uncert <- dat |> + dplyr::filter(label == "bmsy") |> + dplyr::select(uncertainty) |> + as.numeric() return(as.numeric(B.msy) - as.numeric(B.msy.min_uncert)) } - + if (returned_kq == "B.msy.max") { - B.msy <- dat |> dplyr::filter(label == "bmsy") |> dplyr::select(estimate) |> as.numeric() - B.msy.min_uncert <- dat |> dplyr::filter(label == "bmsy") |> dplyr::select(uncertainty) |> as.numeric() + B.msy <- dat |> + dplyr::filter(label == "bmsy") |> + dplyr::select(estimate) |> + as.numeric() + B.msy.min_uncert <- dat |> + dplyr::filter(label == "bmsy") |> + dplyr::select(uncertainty) |> + as.numeric() return(as.numeric(B.msy) + as.numeric(B.msy.min_uncert)) } - + # plot_fishing_mortality()----- if (returned_kq == "F.min") { return( @@ -182,7 +192,7 @@ calc_kqs <- function(returned_kq, round(digits = 3) ) } - + if (returned_kq == "F.max") { return( prepared_data$estimate |> @@ -191,7 +201,7 @@ calc_kqs <- function(returned_kq, round(digits = 3) ) } - + if (returned_kq == "F.terminal.year") { return( filter_data( @@ -210,16 +220,16 @@ calc_kqs <- function(returned_kq, unique() ) } - + if (returned_kq == "F.target") { return( dat |> - dplyr::filter(grepl('f_target', label) | grepl('f_msy', label) | (grepl('fishing_mortality_msy', label) & is.na(year))) |> + dplyr::filter(grepl("f_target", label) | grepl("f_msy", label) | (grepl("fishing_mortality_msy", label) & is.na(year))) |> dplyr::pull(estimate) |> round(digits = 3) ) } - + if (returned_kq == "f.limit") { if ("log_flimit" %in% unique(dat$label)) { return( @@ -236,7 +246,6 @@ calc_kqs <- function(returned_kq, } - # TODO: update key quantities functions to work with a specified 'dir' instead of default 'getwd()'? # TODO: update key quantities functions for plots that need to extract values from KQs csv to calculate their own, dependent KQs (none present in current plotting functions) diff --git a/R/utils_table.R b/R/utils_table.R index 9f785482..0935073a 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -194,11 +194,11 @@ check_label_differences <- function(dat, index_variables, id_group = NULL) { #' to reduce redundancy in the table. #' merge_error <- function( - table_data, - id_col_vals, - unit_label, - uncert_lab - ) { + table_data, + id_col_vals, + unit_label, + uncert_lab +) { # TODO: change fleets to grouping when the data is indexed by factors other than fleet lapply(table_data, function(tab_dat) { label_cols <- names(tab_dat)[-c(1, grep(glue::glue("^{uncert_lab}"), names(tab_dat)))] @@ -211,12 +211,13 @@ merge_error <- function( tolower(l_col), paste( stringr::str_escape(unlist(id_col_vals, use.names = FALSE)), - collapse = "|") + collapse = "|" ) - + ) + # Identify which uncert col aligns with l_col uncert_col <- uncert_cols[grep(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( @@ -226,7 +227,7 @@ merge_error <- function( # maybe not good practice to insert dash? # ifelse( # is.na(.data[[l_col]]), - "-" + "-" # as.character(.data[[l_col]]) # ) ) @@ -234,13 +235,13 @@ merge_error <- function( # Remove uncertainty colummn id'd in this step of the loop dplyr::select(-dplyr::all_of(uncert_col)) } # close loop combining label and uncertainty - + # Adjust all header label names now header_labs <- stringr::str_replace_all(colnames(tab_dat), "_", " ") |> stringr::str_to_title() header_labs2 <- glue::glue("{header_labs[-1]}{ifelse(unit_label!='', paste0(' ', unit_label,' '), ' ')}({uncert_lab})") colnames(tab_dat) <- c(header_labs[1], header_labs2) - + return(tab_dat) }) # close and end lapply } diff --git a/tests/testthat/test-convert_output.R b/tests/testthat/test-convert_output.R index 39fbc094..ba1ff489 100644 --- a/tests/testthat/test-convert_output.R +++ b/tests/testthat/test-convert_output.R @@ -74,7 +74,7 @@ test_that("missing arguments trigger warnings or errors", { test_that("r4ss::ss_output object is compatible.", { simple_r4ss <- readRDS(fs::path("fixtures", "r4ss_output", "simple_small", "simple_r4ss.rds")) - + expect_no_error(result <- convert_output(simple_r4ss)) expect_equal(dim(result)[2], 34) }) diff --git a/tests/testthat/test-table_index.R b/tests/testthat/test-table_index.R index cc3df6e7..12cb3855 100644 --- a/tests/testthat/test-table_index.R +++ b/tests/testthat/test-table_index.R @@ -6,7 +6,7 @@ test_that("table_index generates plots without errors", { interactive = FALSE ) ) - + # expect error-free plot with many arguments expect_no_error( table_index( @@ -15,8 +15,8 @@ test_that("table_index generates plots without errors", { tables_dir = getwd() ) ) - - + + # expect gt object is returned # adjust this test to work for multiple output tables # expect_s3_class( @@ -40,11 +40,11 @@ test_that("rda file made when indicated", { make_rda = TRUE, tables_dir = getwd() ) - + # expect that both tables dir and the index_table.rda file exist expect_true(dir.exists(fs::path(getwd(), "tables"))) expect_true(file.exists(fs::path(getwd(), "tables", "index_table.rda"))) - + # erase temporary testing files file.remove(fs::path(getwd(), "captions_alt_text.csv")) unlink(fs::path(getwd(), "tables"), recursive = T) diff --git a/tests/testthat/test-theme_table.R b/tests/testthat/test-theme_table.R index 577d3235..6e990d85 100644 --- a/tests/testthat/test-theme_table.R +++ b/tests/testthat/test-theme_table.R @@ -1,5 +1,4 @@ test_that("theme_table applies NOAA formatting correctly", { - # Test with a gt table object gt_obj <- gt::gt(head(cars)) result_gt <- theme_table(gt_obj)