diff --git a/R/convert_output.R b/R/convert_output.R index 63c8d17b..e5652322 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -4,7 +4,7 @@ #' #' @param file Assessment model output file path #' @param model Assessment model used in evaluation ("ss3", "bam", -#' "fims"). +#' "fims", "rceattle). #' @param fleet_names Names of fleets in the assessment model as #' shortened in the output file. If fleet names are not properly read, then #' indicate the fleets names as an acronym in a vector @@ -97,42 +97,60 @@ convert_output <- function( out_new <- out_new[-1, ] # Check if path links to a valid file - url_pattern <- "^(https?|ftp|file):\\/\\/[-A-Za-z0-9+&@#\\/%?=~_|!:,.;]*[-A-Za-z0-9+&@#\\/%=~_|]$" - if (grepl(url_pattern, file)) { - check <- httr::HEAD(file) - url <- httr::status_code(check) - if (url == 404) cli::cli_abort(c(message = "Invalid URL.")) - } else { - if (!file.exists(file)) { - cli::cli_abort(c( - message = "`file` not found.", - "i" = "`file` entered as {file}" - )) + if (is.character(file)) { + url_pattern <- "^(https?|ftp|file):\\/\\/[-A-Za-z0-9+&@#\\/%?=~_|!:,.;]*[-A-Za-z0-9+&@#\\/%=~_|]$" + if (grepl(url_pattern, file)) { + check <- httr::HEAD(file) + url <- httr::status_code(check) + if (url == 404) cli::cli_abort(c(message = "Invalid URL.")) + } else { + if (!file.exists(file)) { + cli::cli_abort(c( + message = "`file` not found.", + "i" = "`file` entered as {file}" + )) + } } } # Recognize model through file extension - if (is.null(model)) { - model <- switch(stringr::str_extract(file, "\\.([^.]+)$"), - ".sso" = { - cli::cli_alert_info("Processing Stock Synthesis output file...") - "ss3" - }, - ".rdat" = { - cli::cli_alert_info("Processing BAM output file...") - "bam" - }, - ".rds" = { - cli::cli_alert_info("Processing WHAM output file...") - "wham" - }, - ".RDS" = { + if (is.character(file)) { + if (is.null(model)) { + model <- switch(stringr::str_extract(file, "\\.([^.]+)$"), + ".sso" = { + cli::cli_alert_info("Processing Stock Synthesis output file...") + "ss3" + }, + ".rdat" = { + cli::cli_alert_info("Processing BAM output file...") + "bam" + }, + ".rds" = { + cli::cli_alert_info("Processing WHAM output file...") + "wham" + }, + ".RDS" = { + cli::cli_alert_info("Processing FIMS output file...") + "fims" + }, + + cli::cli_abort("Unknown file type. Please indicate model.") + ) + } + } else { + model <- switch (class(file)[1], + "fims" = { cli::cli_alert_info("Processing FIMS output file...") "fims" }, + "Rceattle" = { + cli::cli_alert_info("Processing Rceattle output file...") + "rceattle" + }, cli::cli_abort("Unknown file type. Please indicate model.") ) } + #### SS3 #### # Convert SS3 output Report.sso file @@ -1764,6 +1782,190 @@ convert_output <- function( } fims_output[setdiff(tolower(names(out_new)), tolower(names(fims_output)))] <- NA out_new <- fims_output + #### Rceattle #### + } else if (model == "rceattle") { + # Want to extract and set values from: + # quantities, sdrep, and estimated_params + # take similar approach to SS3 when only some keywords were converted + # can late take approach like BAM? + # TODO: Do we want users to input the saved file or already loaded into the R environment? + if (is.character(file)) { + dat <- readRDS(file) + } else { + dat <- file + } + + # Extract or use fleet names + if (is.null(fleet_names)) { + fleet_names <- names(dat$estimated_params$index_ln_q) + } + + # Output fleet names in console + cli::cli_alert_info("Identified fleet names:") + cli::cli_alert_info("{fleet_names}") + # Create list for morphed dfs to go into (for rbind later) + out_list <- list() + + factors <- c("year", "fleet", "fleet_name", "age", "sex", "area", "seas", "season", "time", "era", "subseas", "subseason", "platoon", "platoo", "growth_pattern", "gp", "nsim", "age_a") + errors <- c("StdDev", "sd", "se", "SE", "cv", "CV", "stddev") + # units <- c("mt", "lbs", "eggs") + + for (p in (2:length(dat))[-c(6, 8, 9, 10)]) { + extract <- dat[p] + module_name <- names(extract) + cli::cli_alert_info("Processing {module_name}") + if (module_name == "sdrep") { + # this does not include all elements from sdrep list + df <- extract[[1]] + # Extract values from sdrep element in listdrep + values <- data.frame( + label = names(extract[[1]]$value), + estimate = extract[[1]]$value, + uncertainty = extract[[1]]$sd, + uncertainty_label = "sd" + ) + values_count <- values |> + dplyr::group_by(label) |> + dplyr::count() + values <- values |> + dplyr::left_join( + { + values |> dplyr::group_by(label) |> dplyr::count() + }, + by = "label" + ) + # make year column + year_col <- rep( + file[["data_list"]]$styr:file[["data_list"]]$projyr, + length(unique( + dplyr::filter(values_count, n == length(file[["data_list"]]$styr:file[["data_list"]]$projyr)) |> + dplyr::pull(label) + )) + ) + + df2 <- values |> + dplyr::filter(n == length(file[["data_list"]]$styr:file[["data_list"]]$projyr)) |> + dplyr::mutate(year = year_col) + + df2 <- values |> + dplyr::filter( + n != length(file[["data_list"]]$styr:file[["data_list"]]$projyr) + ) |> + dplyr::mutate(year = NA) |> + rbind(df2) + + # Extract parameter values ts + par_fixes <- data.frame( + label = names(extract[[1]]$par.fixed), + estimate = extract[[1]]$par.fixed + ) + par_fixes_count <- par_fixes |> + dplyr::group_by(label) |> + dplyr::count() + par_fixes <- par_fixes |> + dplyr::left_join( + par_fixes_count, + by = "label" + ) + + year_col_par_fix <- rep( + file[["data_list"]]$styr:file[["data_list"]]$endyr, + length(unique( + dplyr::filter(par_fixes_count, n == length(file[["data_list"]]$styr:file[["data_list"]]$endyr)) |> + dplyr::pull(label) + )) + ) + + df3 <- par_fixes |> + dplyr::filter(n == length(file[["data_list"]]$styr:file[["data_list"]]$endyr)) |> + dplyr::mutate(year = year_col_par_fix) + df3 <- par_fixes |> + dplyr::filter( + n != length(file[["data_list"]]$styr:file[["data_list"]]$endyr) + ) |> + dplyr::mutate(year = NA) |> + rbind(df3) |> + dplyr::mutate( + uncertainty = NA, + uncertainty_label = NA + ) + # not sure how pop_scalar is indexed + # not sure how log_index_hat is indexes + # Did not use r_sd for the error in rec bc used it from the other element in the list + + df4 <- rbind(df2, df3) |> + dplyr::select(-n) |> + dplyr::mutate( + module_name = module_name + ) + + df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA + out_list[[names(extract)]] <- df4 + } else if (is.list(extract[[1]])) { # indicates vector and list + if (any(vapply(extract[[1]], is.matrix, FUN.VALUE = logical(1)))) { + ############################################################## + df <- extract[[1]] |> + expand_element(fleet_names = fleet_names) |> + dplyr::mutate( + module_name = module_name + ) + df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA + out_list[[names(extract)]] <- df + + } else if (any(vapply(extract[[1]], is.vector, FUN.VALUE = logical(1)))) { # all must be a vector to work - so there must be conditions for dfs with a mix + extract_list <- list() + # mod_name1 <- names(extract) + for (i in seq_along(extract[[1]])) { + # need to add condition or something in expand_element to account for data thats formatted differently but is still a list i.e. p=9 + if (is.list(extract[[1]][i][[1]])) { + # mod_name2 <- glue::glue("{module_name}_{names(extract[[1]][i])}") + # comment out message once finished development + cli::cli_alert_info("Processing {names(extract[[1]][i])}") + + df <- extract[[1]][i][[1]] |> + expand_element(fleet_names = fleet_names) |> + dplyr::mutate( + module_name = module_name # mod_name2 + ) # |> + # suppressWarnings() + } else { + df <- data.frame( + estimate = extract[[1]][[i]][[1]], + label = names(extract[[1]][i]), + module_name = module_name + ) + } + df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA + extract_list[[names(extract[[1]][i])]] <- df + } + new_df <- Reduce(rbind, extract_list) + out_list[[names(extract)]] <- new_df + } else { + cli::cli_alert_warning("Not compatible.") + } + } else { + cli::cli_alert_warning("Not compatible yet.") + } + # } else if (is.list(extract[[1]])) { # list only + # } else if (is.matrix(extract[[1]])) { # matrix only + # } else { + # cli::cli_alert_warning(paste(names(extract), " not compatible.", sep = "")) + # } # close if statement + } # close loop over objects listed in dat file + # Finish out df + out_new <- Reduce(rbind, out_list) |> + # Add era as factor into BAM conout + dplyr::mutate( + # TODO: replace all periods with underscore if naming convention is different + label = tolower(label), + # set era + era = dplyr::if_else( + year > dat$data_list$endyr, + "fore", + "time" + ) + ) + } else { cli::cli_abort(c( message = "Output file not compatible.", @@ -1803,20 +2005,29 @@ convert_output <- function( ) ) |> suppressWarnings() - if (tolower(model) == "ss3") { - con_file <- system.file("resources", "ss3_var_names.csv", package = "stockplotr", mustWork = TRUE) - var_names_sheet <- utils::read.csv(con_file, na.strings = "") - } else if (tolower(model) == "bam") { - con_file <- system.file("resources", "bam_var_names.csv", package = "stockplotr", mustWork = TRUE) - var_names_sheet <- utils::read.csv(con_file, na.strings = "") |> - dplyr::mutate( - label = tolower(label) - ) - } else if (tolower(model) == "fims") { - con_file <- system.file("resources", "fims_var_names.csv", package = "stockplotr", mustWork = TRUE) - var_names_sheet <- utils::read.csv(con_file, na.strings = "") - } - + # if (tolower(model) == "ss3") { + # con_file <- system.file("resources", "ss3_var_names.csv", package = "stockplotr", mustWork = TRUE) + # var_names_sheet <- utils::read.csv(con_file, na.strings = "") + # } else if (tolower(model) == "bam") { + # con_file <- system.file("resources", "bam_var_names.csv", package = "stockplotr", mustWork = TRUE) + # var_names_sheet <- utils::read.csv(con_file, na.strings = "") |> + # dplyr::mutate( + # label = tolower(label) + # ) + # } else if (tolower(model) == "fims") { + # con_file <- system.file("resources", "fims_var_names.csv", package = "stockplotr", mustWork = TRUE) + # var_names_sheet <- utils::read.csv(con_file, na.strings = "") + # } else if (tolower(model) == "rceattle") { + # con_file <- system.file("resources", "rceattle_var_names.csv", package = "stockplotr", mustWork = TRUE) + # var_names_sheet <- utils::read.csv(con_file, na.strings = "") + # } + + # edit: here is a different way of loading in the csv sheets + con_file <- system.file("resources", glue::glue("{model}_var_names.csv"), package = "stockplotr", mustWork = TRUE) + # temporarily add call to local csv so I can test + # con_file <- glue::glue("~/GitHub/stockplotr/inst/resources/{model}_var_names.csv") + var_names_sheet <- utils::read.csv(con_file, na.strings = "") + if (file.exists(con_file)) { # Remove 'X' column if it exists var_names_sheet <- var_names_sheet |> diff --git a/R/utils.R b/R/utils.R index c174f416..3da25705 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,10 +2,6 @@ # General utility functions # @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -# General utility functions -# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - # Check end_year isn't past current year for non-projections plots # make year character if not null check_year <- function( @@ -54,7 +50,8 @@ get_ncol <- function(file, skip = 0) { nummax } -#---- SS3_extract_df ---- +#------------------------------------------------------------------------------ + # Helper for SS3 output converter # Function to extract rows, identify the dfs, and clean them up # SS3_extract_df <- function(dat, label) { @@ -126,7 +123,8 @@ SS3_extract_df <- function(dat, label) { as.data.frame(clean_dt) } -#---- SS3_extract_fleet ---- +#------------------------------------------------------------------------------ + SS3_extract_fleet <- function(dat, vers) { # Determine where fleet names are located base on model version # TODO: test other SS3 models and/or write converter based on r4ss::ss_output @@ -183,7 +181,7 @@ SS3_extract_fleet <- function(dat, vers) { fleets } -#---------------------------------------------------------- +#------------------------------------------------------------------------------ # # Baseline units for models # baseline_units <- function() { @@ -194,3 +192,82 @@ SS3_extract_fleet <- function(dat, vers) { # "weight" # ) # } + +#------------------------------------------------------------------------------ + +#' @param x unlisted object from model output + +expand_element <- function(input_list, fleet_names = "Pollock") { + + # Use map_dfr to iterate over each element of the list + # .id = "origin_var" keeps track of which list element the data came from + purrr::imap_dfr(input_list, function(x, name) { + + # Skip empty/null elements immediately + if (length(x) == 0 || is.null(x)) return(NULL) + + # Standardize current element 'x' to a Long Data Frame + if (!is.null(dim(x)) && length(dim(x)) > 1) { + # Handles Arrays/Matrices + df <- as.data.frame.table(x, responseName = "estimate") |> + # Unite all Var columns into one string, e.g., "Pollock.Sex combined.Age1" + tidyr::unite("dim_info", tidyselect::matches("^Var"), sep = ".", na.rm = TRUE) |> + # Prepend the element name: "M1_at_age.Pollock.Sex combined.Age1" + dplyr::mutate(label_init = paste0(name, ".", dim_info)) |> + dplyr::select(-dim_info) + } else { + # Handles Vectors/Named Vectors + df <- tibble::enframe(x, name = "dim_info", value = "estimate") |> + dplyr::mutate(label_init = dplyr::case_when( + is.na(dim_info) | dim_info == "" ~ as.character(name), + # grepl("//.", dim_info) ~ dim_info, # condition where the name is the only thing in the label + TRUE ~ paste0(name, ".", dim_info) + )) |> + dplyr::select(-dim_info) + } + + # Process the labels + df |> + dplyr::mutate( + label_init = as.character(label_init), + + # Pull parameter name + label = dplyr::case_when( + stringr::str_extract(label_init, "^[^\\.]+") == "rec_pars" ~ stringr::str_extract(label_init, "[^\\.]+$"), + TRUE ~ stringr::str_extract(label_init, "^[^\\.]+") + ), + + # Extract Age + age = dplyr::case_when( + grepl("age", label_init, ignore.case = TRUE) ~ + as.numeric(stringr::str_extract(label_init, "(?<=\\.[Aa]ge)[0-9]+(?=\\.|$)")), + TRUE ~ NA_real_ + ), + + # Extract Sex + sex = dplyr::case_when( + grepl("Sex.combined|combined", label_init, ignore.case = TRUE) ~ "combined", + grepl("female", label_init, ignore.case = TRUE) ~ "female", # check havent seen example of this! + grepl("male", label_init, ignore.case = TRUE) ~ "male", # check havent seen example of this! + TRUE ~ NA_character_ + ), + + # Extract Year (4 digits) + year = dplyr::case_when( + grepl("[0-9]{4}", label_init) ~ as.numeric(stringr::str_extract(label_init, "[0-9]{4}")), + TRUE ~ NA_real_ + ), + + # Extract Fleet + fleet = dplyr::case_when( + grepl(paste0(fleet_names, collapse = "|"), label_init) ~ + stringr::str_extract(label_init, paste0(fleet_names, collapse = "|")), + TRUE ~ NA_character_ + ) + ) |> + # Ensure 'estimate' is numeric and clean up temp columns + dplyr::mutate(estimate = as.numeric(estimate)) |> + dplyr::select(-label_init) + }) +} + diff --git a/inst/resources/rceattle_var_names.csv b/inst/resources/rceattle_var_names.csv new file mode 100644 index 00000000..7feff877 --- /dev/null +++ b/inst/resources/rceattle_var_names.csv @@ -0,0 +1,202 @@ +module_name,label,alt_label +initial_params,ln_finit, +initial_params,ln_flimit,ln_fishing_mortality_limit +initial_params,ln_ftarget,ln_fishing_mortality_target +initial_params,ln_m1, +initial_params,ln_m1_dev, +initial_params,ln_pop_scalar, +initial_params,ln_sel_slp, +initial_params,ln_sel_slp_dev, +initial_params,log_gam_a, +initial_params,log_gam_b, +initial_params,log_phi, +initial_params,m1_beta, +initial_params,m1_dev_ln_sd, +initial_params,m1_rho, +initial_params,proj_f_prop, +initial_params,r0, +initial_params,r_ln_sd, +initial_params,rec_dev,recruitment_deviations +initial_params,sel_coff, +initial_params,sel_coff_dev, +initial_params,sel_curve_pen, +initial_params,sel_curve_pen, +initial_params,sel_dev_ln_sd, +initial_params,sel_inf, +initial_params,sel_inf_dev, +map,1, +map,2, +map,3, +map,alpha, +map,beta, +map,beta_rec_pars, +map,catch_ln_sd,ln_catch_sd +map,comp_weights,composition_weights +map,diet_comp_weights,diet_composition_weights +map,dummy, +map,index_ln_q, +map,index_ln_sd, +map,index_q_beta, +map,index_q_dev, +map,index_q_dev_ln_sd, +map,index_q_ln_sd, +map,index_q_rho, +map,init_dev, +map,ln_f,ln_fishing_mortality +map,ln_finit,ln_fishing_mortality_initial +map,ln_flimit,ln_fishing_mortality_limit +map,ln_ftarget,ln_fishing_mortality_target +map,ln_m1, +map,ln_m1_dev, +map,ln_pop_scalar, +map,ln_sel_slp, +map,ln_sel_slp_dev, +map,log_gam_a, +map,log_gam_b, +map,log_phi, +map,m1_beta, +map,m1_dev_ln_sd, +map,m1_rho, +map,proj_f_prop, +map,r0, +map,r_ln_sd, +map,rec_dev,recruitment_deviations +map,sel_coff, +map,sel_coff_dev, +map,sel_curve_pen, +map,sel_curve_pen, +map,sel_dev_ln_sd, +map,sel_inf, +map,sel_inf_dev, +phase_params,alpha, +phase_params,beta, +phase_params,beta_rec_pars, +phase_params,catch_ln_sd,ln_catch_sd +phase_params,comp_weights,composition_weights +phase_params,diet_comp_weights,diet_composition_weights +phase_params,dummy, +phase_params,index_ln_q, +phase_params,index_ln_sd, +phase_params,index_q_beta, +phase_params,index_q_dev, +phase_params,index_q_dev_ln_sd, +phase_params,index_q_ln_sd, +phase_params,index_q_rho, +phase_params,init_dev, +phase_params,ln_f,ln_fishing_mortality +phase_params,ln_finit,ln_fishing_mortality_initial +phase_params,ln_flimit,ln_fishing_mortality_limit +phase_params,ln_ftarget,ln_fishing_mortality_target +phase_params,ln_m1, +phase_params,ln_m1_dev, +phase_params,ln_pop_scalar, +phase_params,ln_sel_slp, +phase_params,ln_sel_slp_dev, +phase_params,log_gam_a, +phase_params,log_gam_b, +phase_params,log_phi, +phase_params,m1_beta, +phase_params,m1_dev_ln_sd, +phase_params,m1_rho, +phase_params,proj_f_prop, +phase_params,r0, +phase_params,r_ln_sd, +phase_params,rec_dev,recruitment_deviations +phase_params,sel_coff, +phase_params,sel_coff_dev, +phase_params,sel_curve_pen, +phase_params,sel_curve_pen, +phase_params,sel_dev_ln_sd, +phase_params,sel_inf, +phase_params,sel_inf_dev, +quantities,age_hat,catch +quantities,age_obs_hat,catch_adjusted +quantities,avail_food, +quantities,avg_r,recruitment_mean +quantities,avgn_at_age,abundance_average +quantities,b0, +quantities,b_eaten, +quantities,b_eaten_as_prey, +quantities,biomass, +quantities,biomass_at_age,biomass +quantities,biomass_depletion,biomass_biomass_unfished +quantities,catch_hat,landings +quantities,comp_hat, +quantities,comp_n, +quantities,comp_obs, +quantities,consumption_at_age, +quantities,diet_hat, +quantities,diet_obs, +quantities,dynamicb0, +quantities,dynamicsb0, +quantities,dynamicsbf, +quantities,exploitable_biomass, +quantities,f_at_age,fishing_mortality +quantities,f_flt,fishing_mortality +quantities,f_flt_age,fishing_mortality +quantities,f_spp,fishing_mortality +quantities,flimit,fishing_mortality_target +quantities,flt_sel_maxage, +quantities,ft, +quantities,ftarget,fishing_mortality_limit +quantities,gam_a, +quantities,gam_b, +quantities,index_hat, +quantities,index_q, +quantities,jnll, +quantities,jnll_comp, +quantities,ln_catch_sd, +quantities,ln_index_sd, +quantities,log_index_hat, +quantities,log_ssb,log_spawning_biomass +quantities,m1_at_age,m1 +quantities,m2_at_age,m2 +quantities,m2_prop,proportion_m2 +quantities,m_at_age,natural_mortality +quantities,max_catch_hat, +quantities,n_at_age,abundance +quantities,nbyage0,abundance_rec_hat_f0 +quantities,nbyagef,abundance_rec_hat_f_target +quantities,nbyagespr,abundance_spr +quantities,pop_scalar, +quantities,proj_f,fishing_mortality +quantities,r,recruitment +quantities,r0, +quantities,r_hat, +quantities,r_init,recruitment_initial +quantities,r_sd,recruitment_sd +quantities,ration, +quantities,sb0,spawning_biomass_0 +quantities,sbf,spawning_biomass_target +quantities,sel,selectivity +quantities,spr0, +quantities,sprfinit,spr_initial +quantities,sprlimit,spr_limit +quantities,sprtarget,spr_target +quantities,ssb,spawning_biomass +quantities,ssb_depletion,spawning_biomass_depletion +quantities,steepness, +quantities,stom_div_bio, +quantities,suit_other, +quantities,suitability, +quantities,true_age_comp_hat, +quantities,unweighted_jnll_comp, +quantities,vulnerability, +quantities,vulnerability_other, +quantities,z_at_age,total+mortality +sdrep,biomass, +sdrep,index_ln_q, +sdrep,init_dev, +sdrep,ln_f, +sdrep,ln_sel_slp, +sdrep,ln_sel_slp_dev, +sdrep,log_index_hat, +sdrep,log_ssb,log_spawning_biomass +sdrep,pop_scalar, +sdrep,r,recruitment +sdrep,r_sd,recruitment_sd +sdrep,rec_dev,recruitment_deviations +sdrep,rec_pars,recruitment_parameters +sdrep,sel_inf, +sdrep,sel_inf_dev, +sdrep,ssb,spawning_biomass