[feat] Extract and format data for asar to SIS function

NAMESPACE

@@ -5,6 +5,7 @@ export(create_latex_table)
 export(create_rda)
 export(export_rda)
 export(extract_caps_alttext)
+export(extract_sis_data)
 export(filter_data)
 export(plot_aa)
 export(plot_abundance_at_age)

R/extract_sis_data.R

@@ -0,0 +1,391 @@
+#' Extract data from model results to send to SIS
+#'
+#' Semi-automate the extraction of key quantities from model results for eventual transmittance to SIS via `asar::export_to_sis()`.
+#' 
+#' @param sis_data_dir Path. Location to save the sis_assmt_template.csv and
+#' sis_ts_template.csv files or, if present, the location of the
+#' existing sis_assmt_template.csv file.
+#' 
+#' Default: The working directory.
+#' 
+#' @param key_quantities_dir Path. Location of the existing key_quantities.csv file.
+#' 
+#' Default: The working directory.
+#' 
+#' @param figures_tables_dir Path. Location of the existing 'figures' and 'tables' directories.
+#' 
+#' Default: The working directory.
+#' 
+#' @details This function acts within the following workflow:
+#' 
+#' 1. When a stock assessment is scheduled to conclude, SIS will generate an
+#'  attachment or prompt containing metadata and identifiers.
+#' 2. The user will open two csv files containing placeholders for all of the data required by SIS: sis_assmt_template.csv (assessment summary data) and sis_ts_template.csv (time series data). There are three ways to obtain these files:
+#' 2a. Run `stockplotr::extract_sis_data()`, which will generate, populate, and export the templates with data originating from a converted model results file.
+#' 2b. Generate blank files by running `asar::create_blank_sis()`.
+#' 2c. Locate blank files in the "report" folder generated by running `asar::create_template()`.
+#' 3. The user will add the remaining necessary data into the csv files, ensuring that all required fields are completed.
+#' 4. Run `export_to_sis()`, which will format and upload this data to a specific Google Drive folder.
+#' 5. The uploaded contents will be resubmitted to SIS to finalize the record.
+#' 
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' extract_sis_data(
+#'   sis_data_dir = getwd(),
+#'   key_quantities_dir = "my_dir",
+#'   figures_tables_dir = "my_other_dir"
+#' )
+#' }
+#'
+extract_sis_data <- function(sis_data_dir = getwd(),
+                             key_quantities_dir = getwd(),
+                             figures_tables_dir = getwd()
+                             ) {
+  # check if existing figures and tables folders exist; if both absent, throw an error
+  if (!dir.exists(fs::path(figures_tables_dir, "figures")) & !dir.exists(fs::path(figures_tables_dir, "tables"))) {
+    cli::cli_abort("Neither 'figures' nor 'tables' folders were found in {figures_tables_dir}. Please check the `figures_tables_dir` path, or export figures and tables, and then try again.")
+    }
+
+  # Check if existing data files exist; if not, start from blank templates
+  if (!file.exists(fs::path(sis_data_dir, "sis_assmt_template.csv"))) {
+    assmt_dat <- read.csv(fs::path("inst/resources/sis_assmt_template.csv"), stringsAsFactors = FALSE)
+    cli::cli_alert_info("No existing sis_assmt_template.csv found in {sis_data_dir}. Using blank template.")
+  } else {
+    assmt_dat <- read.csv(fs::path(sis_data_dir, "sis_assmt_template.csv"), stringsAsFactors = FALSE)
+        cli::cli_alert_success("Found existing sis_assmt_template.csv in {sis_data_dir}.")
+  }
+
+    ts_dat <- read.csv(fs::path("inst/resources/sis_ts_template.csv"), stringsAsFactors = FALSE)
+
+  # extract key quantities from csv and assign to variables
+  kqs_path <- fs::path(key_quantities_dir, "key_quantities.csv")
+  if (file.exists(kqs_path)){
+    kqs <- read.csv(fs::path(key_quantities_dir,
+                           "key_quantities.csv"), 
+                  stringsAsFactors = FALSE)
+    cli::cli_alert_success("Found existing key_quantities.csv in {key_quantities_dir}.")
+  } else {
+    cli::cli_alert_warning("No existing key_quantities.csv found in {key_quantities_dir}.")
+    cli::cli_alert_info("To obtain key quantities relevant to the sis_assmt_template.csv, run the following functions and specify `make_rda = TRUE`:")
+    cli::cli_bullets(c(
+      "*" = "plot_fishing_mortality()",
+      "*" = "plot_biomass()",
+      "*" = "plot_landings()"
+    ))
+  }
+
+  if (file.exists(kqs_path)){
+    # insert values into the sis_assmt_template.csv file
+    mapping <- tibble::tribble(
+      ~key_quantity,          ~Variable,
+      "landings.end.year",    "AS_LAST_DATA_YEAR",
+      "F.MSY.terminal",       "AS_FMSY",
+      "B.msy",                "AS_BMSY",
+      "B.msy.min",            "AS_BMSY_MIN",
+      "B.msy.max",            "AS_BMSY_MAX",
+      "B.terminal.year",      "AS_B_YEAR",
+      "F.terminal.year",      "AS_F_YEAR",
+      "F.target",             "AS_FTARGET",
+      "F.limit",              "AS_FLIMIT",
+      "B.terminal.est",       "AS_B_BEST",
+      "F.terminal.est",       "AS_F_BEST",
+      "B.terminal.min",       "AS_B_MIN",
+      "B.terminal.max",       "AS_B_MAX",
+      "F.terminal.min",       "AS_F_MIN",
+      "F.terminal.max",       "AS_F_MAX",
+      "F.MSY.terminal.max",   "AS_FMSY_MAX",
+      "F.MSY.terminal.min",   "AS_FMSY_MIN"
+    )
+
+    # Extract values and format into a key-value matching table
+    new_vals <- kqs |> 
+      dplyr::inner_join(mapping, by = "key_quantity") |> 
+      dplyr::mutate(value = as.numeric(value)) |> 
+      dplyr::select(Variable, new_value = value)
+
+    # Update assmt_dat
+    assmt_dat <- assmt_dat |> 
+      dplyr::left_join(new_vals, by = "Variable") |> 
+      dplyr::mutate(Value = ifelse(!is.na(new_value), new_value, Value)) |> 
+      dplyr::select(-new_value)
+  }
+
+  # obtain time series data
+  if (!dir.exists(fs::path(figures_tables_dir, "figures"))) {
+    cli::cli_alert_info("'figures' folder not found in {sis_data_dir}.")
+    cli::cli_alert_danger("Some time series data will not be extracted.")
+  } else {
+    fig_ts <- TRUE
+    # ABUNDANCE
+    tryCatch(
+      {
+        load(fs::path(figures_tables_dir, "figures", "abundance_at_age_figure.rda")) |> suppressWarnings()
+        aaa <- rda[["figure"]][["layers"]][["geom_line"]]$data
+        abundance <- aaa |>
+          dplyr::group_by(year) |>
+          dplyr::summarise(sum = sum(total_fish)) |>
+          dplyr::rename(Abundance = sum)
+      },
+      error = function(e) {
+        cli::cli_alert_warning("Abundance data was not extracted from the 'abundance_at_age_figure.rda' file.")
+        abundance <<- NULL
+      }
+    )
+
+    # SPAWNERS
+    tryCatch({
+      load(fs::path(figures_tables_dir, "figures", "spawning_biomass_figure.rda")) |> suppressWarnings()
+      sb <- rda[["figure"]][["layers"]][["geom_line"]]$data
+      spawning_biomass <- sb |>
+        dplyr::group_by(year) |>
+        dplyr::summarise(sum = sum(estimate)) |>
+        dplyr::rename(Spawners = sum)
+    },
+    error = function(e) {
+      cli::cli_alert_warning("Spawning biomass data was not extracted from the 'spawning_biomass_figure.rda' file.")
+      spawning_biomass <<- NULL
+    }
+    )
+
+    # RECRUITMENT
+    tryCatch({
+      load(fs::path(figures_tables_dir, "figures", "recruitment_figure.rda")) |> suppressWarnings()
+      rec <- rda[["figure"]][["layers"]][["geom_line"]]$data
+      recruitment <- rec |>
+        dplyr::group_by(year) |>
+        dplyr::summarise(sum = sum(predicted_recruitment)) |>
+        dplyr::rename(Recruitment = sum)
+    },
+    error = function(e) {
+      cli::cli_alert_warning("Recruitment data was not extracted from the 'recruitment_figure.rda' file.")
+      recruitment <<- NULL
+    })
+
+    # FISHING MORTALITY
+    tryCatch({
+      load(fs::path(figures_tables_dir, "figures", "fishing_mortality_figure.rda")) |> suppressWarnings()
+      fm <- rda[["figure"]][["layers"]][["geom_line"]]$data
+      fishing_mortality <- fm |>
+        dplyr::group_by(year) |>
+        dplyr::summarise(mean = mean(estimate)) |>
+        dplyr::rename(Fmort = mean)
+    },
+    error = function(e) {
+      cli::cli_alert_warning("Fishing mortality data was not extracted from the 'fishing_mortality_figure.rda' file.")
+      fishing_mortality <<- NULL
+    })
+
+    # INDEX
+    tryCatch({
+      load(fs::path(figures_tables_dir, "figures", "index_figure.rda")) |> suppressWarnings()
+      index <- rda[["figure"]][["layers"]][["geom_line"]]$data
+      index <- index |>
+        dplyr::group_by(year) |>
+        dplyr::summarise(mean = mean(estimate)) |>
+        dplyr::rename(Index = mean)
+    },
+    error = function(e) {
+      cli::cli_alert_warning("Index data was not extracted from the 'index_figure.rda' file.")
+      index <<- NULL
+    })
+  }
+  if (!dir.exists(fs::path(figures_tables_dir, "tables"))) {
+    cli::cli_alert_info("'tables' folder not found in {sis_data_dir}.")
+    cli::cli_alert_danger("Some time series data will not be extracted.")
+    catch <- NULL
+  } else {
+    table_ts <- TRUE
+    tryCatch(
+    {
+      load(fs::path(figures_tables_dir, "tables", "total_catch_table.rda")) |> suppressWarnings()
+      catch <- rda[["table"]][["_data"]]
+      catch_cols <- colnames(catch)
+      cols_without_catch <- c("Sex", "Area", "Season", "Type")
+      if (any(cols_without_catch %in% catch_cols)) {
+        catch <- catch |>
+          dplyr::select(-dplyr::any_of(cols_without_catch))
+      }
+      catch <- catch |>
+        # remove values in parentheses, if present
+        dplyr::mutate(dplyr::across(!Year, ~ stringr::str_remove_all(.x, "\\s*\\(.*?\\)"))) |>
+        dplyr::mutate(dplyr::across(!Year, ~ stringr::str_remove_all(.x, ","))) |>
+        dplyr::mutate(dplyr::across(!Year, ~ as.numeric(.x))) |>
+        # summarize non-Year rows
+        dplyr::rowwise() |>
+        dplyr::mutate(Catch = sum(dplyr::c_across(!Year), na.rm = TRUE)) |>
+        dplyr::ungroup() |>
+        dplyr::select(Year, Catch)
+    },
+    error = function(e) {
+      cli::cli_alert_warning("Catch data will not be extracted from the 'total_catch_table.rda' file.")
+      catch <<- NULL
+    }
+    )
+  }
+
+  if(exists("fig_ts")){
+    summaries <- c("abundance", "spawning_biomass", "recruitment", "fishing_mortality", "index")
+
+    summaries <- summaries[sapply(summaries, function(x) !is.null(get(x)))] 
+
+    # join all summaries by year
+    all_summaries <- c()
+    for (i in seq_along(summaries)) {
+      if (i == 1) {
+        all_summaries <- get(summaries[i])
+      } else {
+        all_summaries <- dplyr::full_join(all_summaries,
+                                          get(summaries[i]),
+                                          by = "year")
+      }
+    }
+  }
+  if (exists("table_ts") & !is.null(catch)){
+    if (!is.null(all_summaries) & exists("fig_ts")){
+      catch <- catch |>
+        dplyr::rename(year = Year)
+      all_summaries <- dplyr::full_join(all_summaries,
+                                      catch,
+                                      by = "year")
+      summaries <- c(summaries, "catch")
+    } else {
+      all_summaries <- get("catch")
+      summaries <- "catch"
+    }
+  }
+
+  ts_options <- summaries[!is.na(summaries)]
+  cli::cli_alert_info("The following time series summaries were extracted:")
+  cli::cli_ul(ts_options)
+  primary_options1 <- c("fishing_mortality", "recruitment", "catch")
+  primary_options2 <- c("spawning_biomass", "abundance")
+
+  if (length(ts_options) == 0) {
+    primary <- NA
+    cli::cli_alert_info("Zero time series summaries were extracted. Please check the figures and tables directories.")
+  } else if (length(ts_options) == 1) {
+    primary <- ts_options
+    cli::cli_alert_info("Only one time series summary was extracted ({primary}) and will be used as the Primary time series.")
+  } else if (length(ts_options) == 2) {
+    cli::cli_alert_info("Two time series summaries were extracted ({ts_options}).")
+    if (any(ts_options %in% primary_options1) & any(ts_options %in% primary_options2)) {
+      cli::cli_alert_info("These categories will be used as the Primary time series.")
+      primary <- ts_options
+    }} else {
+      cli::cli_alert_info("At most, two categories can be chosen as Primary time series:")
+      cli::cli_ul(c(
+        "fishing_mortality OR recruitment OR catch",
+        "spawning_biomass OR abundance"
+      ))
+      if (interactive()) {
+      primary1 <- readline("Which category should be designated as Primary 1?")
+      primary2 <- readline("Which category should be designated as Primary 2?")   
+        if (primary1 %notin% ts_options | primary2 %notin% ts_options) {
+          cli::cli_abort("Invalid Primary category specified. Please choose from: {ts_options}.")
+        } else {
+          primary <- c(primary1, primary2)
+        }
+      } else {
+        # choose Fmort as first primary if present, otherwise Recruitment, otherwise Catch; and choose Spawners if present, otherwise Biomass
+        cli::cli_alert_info("The following categories will be chosen, in order of preference, as Primary time series:")
+        cli::cli_ul(c(
+          "fishing_mortality OR recruitment OR catch, and",
+          "spawning_biomass OR abundance"
+        ))
+        primary1 <- ifelse("fishing_mortality" %in% ts_options,
+                          "fishing_mortality",
+                          ifelse("recruitment" %in% ts_options,
+                                 "recruitment",
+                                 ifelse("catch" %in% ts_options,
+                                        "catch",
+                                        NA)))
+        primary2 <- ifelse("spawning_biomass" %in% ts_options,
+                          "spawning_biomass",
+                          ifelse("abundance" %in% ts_options,
+                                 "abundance",
+                                 NA))
+        primary <- c(primary1, primary2)
+        primary <- primary[!is.na(primary)]
+        if (length(primary) == 0) {
+          cli::cli_alert_danger("No valid Primary categories found.")
+          primary <- NA
+        } else {
+        cli::cli_alert_info("Primary categor{?y/ies} set to {primary} by default in non-interactive mode.")
+        }
+      }
+    }
+
+  if (length(primary) == 0) {primary <- NA} 
+
+  category_pairs <- list(
+    "fishing_mortality" = "Fmort",
+    "recruitment" = "Recruitment",
+    "catch" = "Catch",
+    "spawning_biomass" = "Spawners",
+    "abundance" = "Abundance", # aka biomass
+    "index" = "Index"
+  )
+
+  primary <- unlist(lapply(primary, function(x) category_pairs[[x]]))
+
+  ts_dat_filled <- all_summaries |>
+    dplyr::rename_with(~ "Year", .cols = matches("^year$")) |>
+    tidyr::pivot_longer(cols = -Year, names_to = "Category", values_to = "Value") |>
+    dplyr::mutate(Primary = ifelse(tolower(Category) %in% tolower(primary), "Y", "")) |>
+    # dplyr::mutate(Primary = ifelse(tolower(Category) == primary, "Y", "")) |>
+    dplyr::mutate(Description = dplyr::case_when(
+      Category == "Abundance" ~ "Total Abundance",
+      Category == "Spawners" ~ as.character(assmt_dat$Value[assmt_dat$Variable == "AS_B_BASIS"]),
+      Category == "Recruitment" ~ "Recruits - Age 1",
+      Category == "Fmort" ~ as.character(assmt_dat$Value[assmt_dat$Variable == "AS_F_BASIS"]),
+      Category == "Index" ~ "Estimated Index",
+      Category == "Catch" ~ "Estimated Total Catch",
+      TRUE ~ NA
+    )) |>
+    dplyr::mutate(Unit = dplyr::case_when(
+      Category == "Abundance" ~ "Number of Fish",
+      Category == "Spawners" ~ as.character(assmt_dat$Value[assmt_dat$Variable == "AS_B_UNIT"]),
+      Category == "Recruitment" ~ ifelse(kqs$value[kqs$key_quantity == "recruitment.units"] == "mt", "Metric Tons", kqs$value[kqs$key_quantity == "recruitment.units"]),
+      Category == "Fmort" ~ as.character(assmt_dat$Value[assmt_dat$Variable == "AS_F_UNIT"]),
+      Category == "Index" ~ "",
+      Category == "Catch" ~ ifelse(kqs$value[kqs$key_quantity == "tot.catch.units"] == " (mt)", "Metric Tons", kqs$value[kqs$key_quantity == "tot.catch.units"]),
+      TRUE ~ NA
+    )) |>
+    dplyr::relocate(Value, .after = Unit)
+
+  # Ensure ts_dat_filled has same cols as ts_dat
+  if (isFALSE(any(colnames(ts_dat_filled) == colnames(ts_dat)))) {
+      cli::cli_abort("Time series data does not match template structure.")
+  }
+
+  # if assmt_dat$Value is NA and Default is 95, change it to Default
+  for (i in seq_len(nrow(assmt_dat))) {
+    if (is.na(assmt_dat$Value[i]) & assmt_dat$Default[i] == 95) {
+      assmt_dat$Value[i] <- assmt_dat$Default[i]
+    }
+  }
+
+  # export files
+  assmt_dat_path <- fs::path(sis_data_dir, "sis_assmt_template.csv")
+  ts_dat_path <- fs::path(sis_data_dir, "sis_ts_template.csv")
+
+  if (file.exists(assmt_dat_path) | file.exists(ts_dat_path)) {
+    cli::cli_alert_info("Existing sis_assmt_template.csv or sis_ts_template.csv found in {sis_data_dir}.")
+    overwrite <- readline("Do you want to overwrite the existing files? (y/n): ")
+    if (tolower(overwrite) == "y") {
+      write.csv(assmt_dat, assmt_dat_path, row.names = FALSE)
+      write.csv(ts_dat_filled, ts_dat_path, row.names = FALSE)
+      cli::cli_alert_success("Files overwritten successfully.")
+    } else {
+      cli::cli_alert_info("Files not overwritten. Please rename the files, then rerun this function to save the data extracted in this function.")
+    }
+  } else {
+    write.csv(assmt_dat, assmt_dat_path, row.names = FALSE)
+    write.csv(ts_dat_filled, ts_dat_path, row.names = FALSE)
+    cli::cli_alert_success("Files saved successfully in {sis_data_dir}.")
+  }
+
+  #TODO: show an example of a filled-out template
+}