diff --git a/R/conout_bam.R b/R/conout_bam.R new file mode 100644 index 00000000..a8588c09 --- /dev/null +++ b/R/conout_bam.R @@ -0,0 +1,520 @@ +conout_bam <- function( + file, + out_new, + fleet_names = NULL +) { + # Extract values from BAM output - model file after following ADMB2R + dat <- dget(file) + + # Find fleet names + if (is.null(fleet_names)) { + # Extract names from indices + indices <- dat$t.series |> + dplyr::select(dplyr::contains("U.") & dplyr::contains(".ob")) + fleets_ind <- stringr::str_extract(as.vector(colnames(indices)), "(?<=U\\.)\\w+(?=\\.ob)") + # Extract names from landings + landings <- dat$t.series |> + dplyr::select(dplyr::contains("L.") & dplyr::contains(".ob") | + dplyr::contains("D.") & dplyr::contains(".ob")) + fleets_land <- stringr::str_extract(as.vector(colnames(landings)), "(?<=L\\.)\\w+(?=\\.ob)") + fleets_disc <- stringr::str_extract(as.vector(colnames(landings)), "(?<=D\\.)\\w+(?=\\.ob)") + # Extract names from lof F dev + parm <- dat$parm.tvec |> + dplyr::select(dplyr::contains("log.F.dev.") | + dplyr::contains("log.F.dev.") & dplyr::contains(".D")) + # fleets_parm_D <- stringr::str_extract(as.vector(colnames(parm)), "(?<=log\\.F\\.dev\\.)\\w+(?=\\.D)") + fleets_parm <- stringr::str_extract(as.vector(colnames(parm)), "(?<=log\\.F\\.dev\\.)\\w+") + fleets <- unique(tolower(c(fleets_ind, fleets_land, fleets_disc, fleets_parm))) + fleet_names <- fleets[!is.na(fleets)] + if (any(is.na(fleet_names))) { + cli::cli_abort("No fleet names found in dataframe. Please indicate the abbreviations of fleet names using fleet_names arg.") + } + } # else { + # # check fleet names are input + # # if (any(is.na(fleet_names))) { + # fleet_names <- fleet_names + # } + # 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") + # argument for function when model == BAM + # fleet_names <- c("cl", "cL","cp","mrip","ct", "hb", "HB", "comm","Mbft","CVID") + + ##### BAM loop ---- + # Extract data from list fit to output df + # Loop over all items to output each object/transform + # Not transforming or including info chunk + for (p in 2:length(dat)) { + extract <- dat[p] + cli::cli_alert_info(glue::glue("Processing {names(extract)}")) + # is the object class matrix, list, or vector + if (is.vector(extract[[1]])) { + if (is.list(extract[[1]])) { # indicates vector and list + if (any(vapply(extract[[1]], is.matrix, FUN.VALUE = logical(1)))) { + extract_list <- list() + for (i in seq_along(extract[[1]])) { + if (is.vector(extract[[1]][[i]])) { + df <- as.data.frame(extract[[1]][i]) |> + tibble::rownames_to_column(var = "age") |> + tidyr::pivot_longer( + cols = -age, + values_to = "estimate", + names_to = "label" + ) |> + dplyr::mutate( + label = names(extract[[1]][i]), + # label_init = names(extract[[1]][i]), + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), + TRUE ~ NA + ), + module_name = names(extract), + label = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), ""), + TRUE ~ label + ) + ) + df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA + extract_list[[names(extract[[1]][i])]] <- df + } else { + df <- as.data.frame(extract[[1]][[i]]) |> + tibble::rownames_to_column(var = "year") + df <- df |> + dplyr::rename_with( + ~ ifelse(max(as.numeric(df$year)) < 50, + c("age_a"), c("year") + ), + year + ) + if (grepl("lcomp", names(extract[[1]][i]))) { + namesto <- "len_bins" + } else if (grepl("acomp", names(extract[[1]][i]))) { + namesto <- "age" + } else { + # Default + namesto <- "age" + } + df2 <- df |> + tidyr::pivot_longer( + cols = -intersect(colnames(df), c("year", "age_a")), + names_to = namesto, + values_to = "estimate" + ) |> + dplyr::mutate( + module_name = names(extract), + label = names(extract[[1]][i]), + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), tolower(label)) ~ stringr::str_extract(tolower(label), paste(fleet_names, collapse = "|")), + TRUE ~ NA + ), # stringr::str_extract(module_name, "(?<=\\.)\\w+(?=\\.)"), + label = dplyr::case_when( + grepl(paste0(fleet_names, collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste0(".", fleet_names, collapse = "|"), ""), + TRUE ~ names(extract[[1]][i]) + ) + # label_init = names(extract[[1]][i]), + + # label = dplyr::case_when( + # is.na(fleet) ~ names(extract[[1]][i]), + # TRUE ~ stringr::str_replace(tolower(label), paste(".", fleet_names, sep = "", collapse = "|"), "") + # ) + ) # stringr::str_replace(module_name, "\\.[^.]+\\.", ".")) + df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + extract_list[[names(extract[[1]][i])]] <- df2 + } # close if statement + } # close for loop + new_df <- Reduce(rbind, extract_list) + out_list[[names(extract)]] <- new_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 + df <- data.frame(extract[[1]]) + if (length(intersect(colnames(df), c(factors, errors))) > 0) { + df2 <- df |> + tidyr::pivot_longer( + cols = -intersect(colnames(df), c(factors, errors)), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate(module_name = names(extract)) + } else { + df2 <- df |> + tidyr::pivot_longer( + cols = tidyselect::everything(), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate(module_name = names(extract)) + } + if (any(grepl(paste(fleet_names, collapse = "|"), unique(df2$label)))) { + df2 <- df2 |> + dplyr::mutate( + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), tolower(label)) ~ stringr::str_extract(tolower(label), paste(fleet_names, collapse = "|")), + # grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(ex, paste(fleet_names,collapse="|")), + TRUE ~ NA + ), + # Number after fleet name is what? variable among df? + age = dplyr::case_when( + grepl("r0$|b0$", tolower(label)) ~ NA, + module_name != "parms" & grepl(".Age[0-9]+.", label) ~ stringr::str_extract(label, "(?<=.Age?)[0-9]+"), + module_name != "parms" & grepl("[0-9]+$", label) & as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_extract(label, "[0-9]+$"), + module_name != "parms" & grepl("_age[0-9]+.", label) ~ stringr::str_extract(label, "(?<=_age?)[0-9]+"), + TRUE ~ NA + ), + label = dplyr::case_when( + # below will only work properly if there are age varying parameters without fleet names in it + module_name == "parms" & !grepl(paste(".", fleet_names, sep = "", collapse = "|"), tolower(label)) ~ label, + module_name == "parm.cons" & !grepl(paste("_", fleet_names, sep = "", collapse = "|"), tolower(label)) ~ label, + grepl(paste(".", fleet_names, "d[0-9]+", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(".", fleet_names, "d[0-9]+", sep = "", collapse = "|"), ".d"), + grepl(paste(".", fleet_names, "[0-9]+$", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(fleet_names, sep = "", collapse = "|"), ""), # "[0-9]+", + grepl(paste(".", fleet_names, "$", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(".", fleet_names, sep = "", collapse = "|"), ""), + grepl(paste("_", fleet_names, "_", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste("_", fleet_names, sep = "", collapse = "|"), ""), + grepl(paste(".", fleet_names, ".d$", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(".", fleet_names, sep = "", collapse = "|"), ""), + grepl(".Age[0-9]+.[a-z]+", label) ~ stringr::str_replace(label, ".Age[0-9]+.[a-z]+", ""), + grepl("[0-9]+$", label) ~ stringr::str_replace(label, "[0-9]+$", ""), + # !is.na(fleet) | !is.na(age) ~ stringr::str_replace(label, paste(c(paste(".", fleet_names, "[0-9]+", sep = ""), ".Age[0-9]+.[a-z]+", "[0-9]+$"), collapse = "|"), ""), + # as.numeric(stringr::str_extract(label, "[0-9]+$")) == 0 ~ label, + # as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_remove(label, "[0-9]+$"), + TRUE ~ label + ), + # additional manipulation of label to remove age in parm.cons + label = dplyr::case_when( + module_name == "parm.cons" & grepl("_age[0-9]+.[a-z]+", label) ~ stringr::str_replace(label, "_age[0-9]+.[a-z]+", ""), + TRUE ~ label + ) + ) + } else if (any(grepl("[0-9]$", unique(df2$label)))) { + df2 <- df2 |> + dplyr::mutate( + fleet = NA, + # Number after fleet name is what? variable among df? + age = dplyr::case_when( + grepl("[0-9]+$", label) & stringr::str_extract(label, "[0-9]+$") < 30 ~ stringr::str_extract(label, "[0-9]+$"), + TRUE ~ NA + ), + # label_init = label, + label = dplyr::case_when( + as.numeric(stringr::str_extract(label, "[0-9]+$")) == 0 ~ label, + as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_remove(label, "[0-9]+$"), + TRUE ~ label + ) + ) + } else { + df2 <- df2 |> + dplyr::mutate( + fleet = ifelse("age" %in% colnames(df2), fleet, NA), + age = ifelse("age" %in% colnames(df2), age, NA), + label = label, + module_name = names(extract) + ) + } + df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + out_list[[names(extract)]] <- df2 + } else { + cli::cli_alert_warning("Not compatible.") + } + } else { # vector only + df <- as.data.frame(extract) |> + tibble::rownames_to_column(var = "label") |> + tidyr::pivot_longer( + cols = -label, + names_to = "module_name", + values_to = "estimate" + ) + if (any(grepl("age", colnames(df)))) { + df <- df |> + tidyr::pivot_longer( + cols = -intersect(c(factors, errors), colnames(df)), + names_to = "age", + values_to = "estimate" + ) |> + dplyr::mutate( + label = names(extract[[1]]), + age = dplyr::case_when( + grepl(".[0-9]$", age) ~ stringr::str_extract(age, "[0-9]"), + grepl(".[0-9][0-9]$", age) ~ stringr::str_extract(age, "[0-9][0-9]"), + TRUE ~ NA + ), + module_name = names(extract) + ) + } + if (any(grepl(paste(fleet_names, collapse = "|"), df$label))) { + df <- df |> + dplyr::mutate( + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), + TRUE ~ NA + ), + label = dplyr::case_when( + is.na(fleet) ~ label, + TRUE ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), "") + ) + ) + } + df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA + out_list[[names(extract)]] <- df + } + } else if (is.list(extract[[1]])) { # list only + if (any(vapply(extract[[1]], is.matrix, FUN.VALUE = logical(1)))) { + extract_list <- list() + for (i in seq_along(extract[[1]])) { + if (is.vector(extract[[1]][[i]])) { + df <- as.data.frame(extract[[1]][i]) |> + tibble::rownames_to_column(var = "age") |> + tidyr::pivot_longer( + cols = -age, + values_to = "estimate", + names_to = "label" + ) |> + dplyr::mutate( + label = names(extract[[1]][i]), + # label_init = names(extract[[1]][i]), + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), + TRUE ~ NA + ), + module_name = names(extract), + label = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), ""), + TRUE ~ label + ) + ) + df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA + extract_list[[names(extract[[1]][i])]] <- df + } else { + df <- as.data.frame(extract[[1]][[i]]) |> + tibble::rownames_to_column(var = "year") + if (grepl("lcomp", names(extract[[1]][i]))) { + namesto <- "len_bins" + } else if (grepl("acomp", names(extract[[1]][i]))) { + namesto <- "age" + } else { + # Default + namesto <- "age" + } + df2 <- df |> + tidyr::pivot_longer( + cols = -year, + names_to = namesto, + values_to = "estimate" + ) |> + dplyr::mutate( + module_name = names(extract), + label = names(extract[[1]][i]), + # label_init = names(extract[[1]][i]), + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), + TRUE ~ NA + ), # stringr::str_extract(module_name, "(?<=\\.)\\w+(?=\\.)"), + label = dplyr::case_when( + is.na(fleet) ~ names(extract[[1]][i]), + TRUE ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), "") + ) + ) # stringr::str_replace(module_name, "\\.[^.]+\\.", ".")) + df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + extract_list[[names(extract[[1]][i])]] <- df2 + } # close if statement + } # close for loop + new_df <- Reduce(rbind, extract_list) + out_list[[names(extract)]] <- new_df + } else if (any(sapply(extract[[1]], is.vector))) { # all must be a vector to work - so there must be conditions for dfs with a mix + df <- data.frame(extract[[1]]) + if (max(as.numeric(row.names(df))) < 1000) { + fac <- "age" + } else if (1000 < max(as.numeric(row.names(df))) & max(as.numeric(row.names(df))) < 2100) { + fac <- "year" + } else { + fac <- "nsim" + } + if (any(colnames(df) %in% c("age", "year"))) { + df <- df + } else { + if (fac == "year") { + df <- tibble::rowid_to_column(df, var = fac) |> + dplyr::mutate(year = as.character(year)) + } else if (fac == "age") { + df <- tibble::rowid_to_column(df, var = fac) |> + dplyr::mutate(age = as.character(age)) + } else if (fac == "nsim") { + df <- tibble::rowid_to_column(df, var = fac) |> + dplyr::mutate(nsim = as.character(nsim)) + } else { + cli::cli_alert_warning("Not compatible") + } + } + # # Check if any col names contain error then select + # if (any(grepl(paste0(errors, collapse = "|"), colnames(df)))) { + # error_cols <- grep(paste0(errors, ".", collapse = "|"), colnames(df)) + # } else { + # error_cols <- NULL + # } + if (length(intersect(colnames(df), c(factors, errors))) > 0) { + df2 <- df |> + tidyr::pivot_longer( + cols = -intersect(colnames(df), c(factors, errors)), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate(module_name = names(extract)) + } else { + df2 <- df |> + tidyr::pivot_longer( + cols = tidyselect::everything(), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate(module_name = names(extract)) + } + if (any(grepl(paste(fleet_names, collapse = "|"), tolower(unique(df2$label))))) { + if ("age" %in% colnames(df2)) { + df2 <- df2 + } else { + df2 <- df2 |> + dplyr::mutate(age = NA) + } + df2 <- df2 |> + dplyr::mutate( + label = tolower(label), + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), + # grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(ex, paste(fleet_names,collapse="|")), + TRUE ~ NA + ), + # Number after fleet name is what? variable among df? + age = dplyr::case_when( + is.na(as.numeric(age)) & grepl("_age[0-9]+_", label) ~ as.numeric(stringr::str_extract(label, "(?<=age:?)[0-9]+")), + is.na(as.numeric(age)) & grepl("[0-9]+$", label) ~ as.numeric(stringr::str_extract(label, "[0-9]+$")), # this is not age + TRUE ~ as.numeric(age) + ), + # area = dplyr::case_when(is.na(age) & grepl("[0-9]+$", label) ~ stringr::str_extract(label, "[0-9]+$"), # this is not age + # TRUE ~ NA), + # Uncomment when units gets added in + # units = dplyr::case_when( + # grepl(paste(units, collapse = "|"), label) ~ stringr::str_extract(label, paste(units, collapse = "|")), + # TRUE ~ NA + # ), + label = dplyr::case_when( + # grepl("_age[0-9]_", label) & grepl(paste("_", fleet_names, "[0-9]+", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_age[0-9]+_", fleet_names, "[0-9]+", sep = "", collapse = "|"), ""), + # grepl("_age[0-9]_", label) & grepl(paste("_", fleet_names, sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_age[0-9]+_", fleet_names, sep = "", collapse = "|"), ""), + # grepl("_age[0-9]_", label) ~ stringr::str_replace(label, "_age[0-9]+_", ""), + # grepl(paste0(rep(fleet_names, times = length(units)), ".", units, collapse = "|"), label) ~ stringr::str_replace(label, paste0(".", rep(fleet_names, times = length(units)), ".", units, collapse = "|"), ""), + grepl(paste("_", fleet_names, "[0-9]+$", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_", fleet_names, "[0-9]+$", sep = "", collapse = "|"), ""), + grepl(paste("_", fleet_names, sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_", fleet_names, sep = "", collapse = "|"), ""), + grepl(paste(".", fleet_names, "[0-9]+$", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(fleet_names, sep = "", collapse = "|"), ""), + grepl(paste(fleet_names, ".", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(fleet_names, ".", sep = "", collapse = "|"), ""), + grepl(paste(".", fleet_names, "d[0-9]+$", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, "d[0-9]+$", sep = "", collapse = "|"), ""), + grepl(paste(".", fleet_names, sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), ""), + grepl(paste(fleet_names, "[0-9]+$", collapse = "|"), label) ~ stringr::str_replace(label, "[0-9]+$", ""), + TRUE ~ label + ) + ) + } else if (any(grepl("[0-9]$", unique(df2$label)))) { + df2 <- df2 |> + dplyr::mutate( + fleet = NA, + # Number after fleet name is what? variable among df? + age = dplyr::case_when( + grepl("[0-9]+$", label) & stringr::str_extract(label, "[0-9]+$") < 30 ~ stringr::str_extract(label, "[0-9]+$"), + TRUE ~ NA + ), + # label_init = label, + label = dplyr::case_when( + as.numeric(stringr::str_extract(label, "[0-9]+$")) == 0 ~ label, + # issue here that stocks with ages > 29 will not be extracted - maybe add condition if F, t or other preceeeds the number then don't extract? + as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_remove(label, "[0-9]+$"), + TRUE ~ label + ) + ) + } else { + df2 <- df2 |> + dplyr::mutate( + fleet = ifelse(any(colnames(df2) %in% c("fleet")), fleet, NA), + age = ifelse(any(colnames(df2) %in% c("age")), fleet, NA), + label = label, + module_name = names(extract) + ) + } + # Move error into column + if (any(grepl(paste0("^", errors, "\\.", collapse = "|"), unique(df2$label)))) { + # Pivot wider only the cv labels and align with their counter part estimate label + error_data <- df2 |> + dplyr::filter(stringr::str_detect(label, paste0("^", errors, ".", collapse = "|"))) |> + dplyr::mutate(match_key = stringr::str_remove(label, paste0("^", errors, ".", collapse = "|"))) |> + dplyr::mutate(uncertainty_label = stringr::str_extract(label, paste0(errors, collapse = "|"))) |> + dplyr::select(year, fleet, match_key, uncertainty = estimate, uncertainty_label) + # filter out error labels + df2_filtered <- df2 |> + dplyr::filter(!stringr::str_detect(label, paste0("^", errors, collapse = "|"))) |> + dplyr::mutate(match_key = stringr::str_extract(label, "^[A-Za-z]+")) + # Join the errors to the final df + df2 <- df2_filtered |> + dplyr::left_join(error_data, by = c("year", "fleet", "match_key")) |> + dplyr::select(-match_key) + } + df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + out_list[[names(extract)]] <- df2 + } else { + cli::cli_alert_warning("Not compatible.") + } + } else if (is.matrix(extract[[1]])) { # matrix only + df <- as.data.frame(extract[[1]]) |> + tibble::rownames_to_column(var = "year") + if (grepl("length", names(extract))) { + namesto <- "len_bins" + } else if (grepl("age", names(extract))) { + namesto <- "age" + } else { + # Default + namesto <- "age" + } + df2 <- df |> + tidyr::pivot_longer( + cols = -year, + names_to = namesto, + values_to = "estimate" + ) |> + dplyr::mutate( + module_name = names(extract), + label = names(extract), + # label_init = names(extract[[1]][i]), + fleet = dplyr::case_when( + grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), + TRUE ~ NA + ), # stringr::str_extract(module_name, "(?<=\\.)\\w+(?=\\.)"), + label = dplyr::case_when( + is.na(fleet) ~ names(extract), + TRUE ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), "") + ) + ) # stringr::str_replace(module_name, "\\.[^.]+\\.", ".")) + df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + out_list[[names(extract)]] <- df2 + } else { + cli::cli_alert_warning(paste(names(extract), " not compatible.", sep = "")) + } # close if statement + } # close loop over objects listed in dat file + + # Place out_list into a single data frame + # VIRG, INIT, TIME, FORE + 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) + ) + if (model == "bam") { + out_new <- dplyr::mutate( + out_new, + era = dplyr::case_when( + year < dat$parms$styr ~ "init", + year >= dat$parms$styr & year <= dat$parms$endyr ~ "time", + year > dat$parms$endyr ~ "fore", + TRUE ~ NA + ) + ) + } + return(out_new) +} diff --git a/R/conout_rceattle.R b/R/conout_rceattle.R new file mode 100644 index 00000000..686a59a0 --- /dev/null +++ b/R/conout_rceattle.R @@ -0,0 +1,486 @@ +conout_rceattle <- function( + file, + out_new, + fleet_names = NULL +) { + # 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)) { + # Anchored and case-insensitive: saveRDS() output is conventionally named + # either .rds or .RDS, and the real assessment files this targets use the + # latter. The unanchored, case-sensitive form rejected them. + if (!grepl("\\.rds$", file, ignore.case = TRUE)) { + cli::cli_abort("File must be in an .rds format otherwise load data into your environment and run `convert_output()` using the loaded data.") + } + dat <- readRDS(file) + } else { + dat <- file + } + + # The standardized output describes one stock and has no species dimension, + # but CEATTLE is a multispecies model. A multispecies fit's `sdrep` holds + # nspp * nyrs values per label, which fails the `n == length(styr:projyr)` + # test used to attach years below, so every biomass / spawning biomass / + # recruitment value would silently come back with `year = NA`. Refuse + # instead: a converted file that quietly merges two stocks is worse than no + # converted file. + # `[[` rather than `$`: `$` partial-matches, so a renamed element would + # return something else and skip the refusal. + if (!"data_list" %in% names(dat)) { + cli::cli_abort(c( + "Rceattle fit has no {.field data_list} element.", + i = "The catch, index and composition data are read from it." + )) + } + nspp <- dat[["data_list"]][["nspp"]] + if (is.null(nspp)) { + cli::cli_abort(c( + "Rceattle fit does not report {.field nspp}, so its species count is unknown.", + i = "The standardized output has no species dimension and must not merge stocks." + )) + } + if (nspp > 1) { + cli::cli_abort(c( + "Rceattle model has {nspp} species, and the standardized output has no species dimension.", + i = "Subset the fit to a single species before converting." + )) + } + + # Extract or use fleet names + if (is.null(fleet_names)) { + fleet_names <- names(dat$estimated_params$index_log_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") + + ##### Loop #### + # Select the modules by name rather than by position. An Rceattle fit's + # element list depends on how it was fitted -- `phase = TRUE` adds + # `.conv_phase` and `phase_params`, and `getsd = FALSE` drops `sdrep` -- so a + # fixed offset selects different modules for different fits of the same + # model. Under `phase = TRUE` the positional form dropped `data_list` and + # passed `obj` to the generic vector handler below, which aborts with + # "attempt to select less than one element in OneIndex". + # + # `sdrep` carries every derived time series, so without it the output holds + # only the input data. Say so rather than returning a table whose biomass + # and recruitment are simply absent. + if (!"sdrep" %in% names(dat)) { + cli::cli_warn(c( + "Rceattle fit has no {.field sdrep}, so the converted output has no biomass, spawning biomass or recruitment.", + i = "Refit with {.code fit_control(getsd = TRUE)} to standardize the derived time series." + )) + } + for (module_name in intersect(c("sdrep", "data_list", "quantities"), names(dat))) { + extract <- dat[module_name] + cli::cli_alert_info("Processing {module_name}") + if (module_name == "sdrep") { + ##### 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( + dat[["data_list"]]$styr:dat[["data_list"]]$projyr, + length(unique( + dplyr::filter(values_count, n == length(dat[["data_list"]]$styr:dat[["data_list"]]$projyr)) |> + dplyr::pull(label) + )) + ) + + df2 <- values |> + dplyr::filter(n == length(dat[["data_list"]]$styr:dat[["data_list"]]$projyr)) |> + dplyr::mutate(year = year_col) + + df2 <- values |> + dplyr::filter( + n != length(dat[["data_list"]]$styr:dat[["data_list"]]$projyr) + ) |> + dplyr::mutate(year = NA) |> + rbind(df2) + + # Extract parameter values ts + # The standard errors of the fixed effects are the square root of the + # diagonal of cov.fixed, in the same order as par.fixed. + has_cov_fixed <- !is.null(extract[[1]]$cov.fixed) + par_fixes <- data.frame( + label = names(extract[[1]]$par.fixed), + estimate = extract[[1]]$par.fixed, + uncertainty = if (has_cov_fixed) sqrt(diag(extract[[1]]$cov.fixed)) else NA_real_, + uncertainty_label = if (has_cov_fixed) "sd" else NA_character_ + ) + # Random effects, such as rec_dev under random_rec = TRUE, are in + # par.random rather than par.fixed. Their variances are in + # diag.cov.random. + if (length(extract[[1]]$par.random) > 0) { + has_cov_random <- !is.null(extract[[1]]$diag.cov.random) + par_fixes <- rbind( + par_fixes, + data.frame( + label = names(extract[[1]]$par.random), + estimate = extract[[1]]$par.random, + uncertainty = if (has_cov_random) sqrt(extract[[1]]$diag.cov.random) else NA_real_, + uncertainty_label = if (has_cov_random) "sd" else NA_character_ + ) + ) + } + 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( + dat[["data_list"]]$styr:dat[["data_list"]]$endyr, + length(unique( + dplyr::filter(par_fixes_count, n == length(dat[["data_list"]]$styr:dat[["data_list"]]$endyr)) |> + dplyr::pull(label) + )) + ) + + df3 <- par_fixes |> + dplyr::filter(n == length(dat[["data_list"]]$styr:dat[["data_list"]]$endyr)) |> + dplyr::mutate(year = year_col_par_fix) + df3 <- par_fixes |> + dplyr::filter( + n != length(dat[["data_list"]]$styr:dat[["data_list"]]$endyr) + ) |> + dplyr::mutate(year = NA) |> + rbind(df3) + # 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 (module_name == "data_list") { + ###### data.list #### + # Only extract specific quantity needs + # comp_data?, index_data, catch_data, weight, Ftarget, Flimit + data_list_list <- list() + + ####### Indices #### + # Extract index_data + df_index <- extract[[1]]$index_data |> + # rename all columns to lower case to match standard + dplyr::rename_with(tolower) |> + dplyr::rename( + fleet = fleet_name, + indices_observed = observation, + block = selectivity_block, + uncertainty = log_sd + ) |> + dplyr::mutate( + # label = "index_observed", + uncertainty_label = "log_sd", + indices_predicted = dat$quantities$index_hat + ) |> + # any_of(): `Q_block` is deprecated in Rceattle and no longer written + # to `index_data`, so naming it directly fails on a current fit while + # still needing to be dropped from an older one. + dplyr::select(-dplyr::any_of(c("fleet_code", "q_block"))) + cli::cli_alert_info("'Selectivity_block' values located in 'block' columns.") + + # check if species > 1 + if (length(unique(df_index$species)) > 1) { + cli::cli_abort("Not currently compatible for multispecies.") + } else { + df_index <- df_index |> + dplyr::select(-species) + } + + # expand df long to have obs and pred in same column with label + df_index_long <- df_index |> + tidyr::pivot_longer( + cols = c(indices_observed, indices_predicted), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate( + module_name = names(extract), + # era = dplyr::if_else( + # year > dat$data_list$endyr, + # "fore", + # NA_character_ + # ) + label = stringr::str_replace_all(label, "indices", "index") + ) + + df_index_long[setdiff(tolower(names(out_new)), tolower(names(df_index_long)))] <- NA + data_list_list[["index_data"]] <- df_index_long + + ####### Catch indexing #### + # Extract catch_data and align with log_index_hat and catch_h + # Modify sdrep in outlist to include index + df_catch <- extract[[1]]$catch_data |> + # dplyr::filter(!is.na(Catch)) |> + dplyr::rename_with(tolower) |> + dplyr::mutate( + module_name = names(extract), + # Set the era here from the year, as the index and composition + # frames do, so the frame is complete where it is built. The mutate + # at the end of the branch recomputes it the same way. + era = dplyr::if_else( + year > dat$data_list$endyr, + "fore", + "time" + ), + catch_h = dat$quantities$catch_hat, + # TODO: follow up on this quantity + # log_index_hat = dat$quantities$log_index_hat + uncertainty_label = "log_sd" + ) |> + dplyr::rename( + catch_predicted = catch_h, + fleet = fleet_name, + block = selectivity_block, + uncertainty = log_sd + ) |> + tidyr::pivot_longer( + cols = c(catch, catch_predicted), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::select(-c(fleet_code, species)) + + # Remove fleet names if do not match object + # if (unique(df_catch$fleet) %notin% fleet_names) { + # df_catch <- df_catch |> + # dplyr::mutate(fleet = NA) + # } + + if (length(unique(df_catch$month)) == 1) { + df_catch$month <- NA + } + df_catch[setdiff(tolower(names(out_new)), tolower(names(df_catch)))] <- NA + data_list_list[["catch_data"]] <- df_catch + + ####### Comp indexing #### + df_comp_obs <- dat$data_list$comp_data |> + dplyr::rename_with(tolower) |> + dplyr::mutate( + label = "index_observed" + ) + + indexing_vars_cols <- colnames(df_comp_obs)[!grepl("comp", colnames(df_comp_obs))] + + # `age_hat` holds one row per row of `comp_data`, in the same order, so + # it binds column-wise. cross_join() paired every observation with the + # whole prediction matrix instead, which is a Cartesian product: on the + # GOAatf fixture it returned the 2,478 correct predictions 59 times + # over, once per row of comp_data, for 146,202 in all. + age_hat <- as.data.frame(dat$quantities$age_hat) + names(age_hat) <- paste0("agehat_", seq_len(ncol(age_hat))) + df_comp_pred <- dplyr::select(df_comp_obs, dplyr::all_of(indexing_vars_cols)) |> + cbind(age_hat) |> + tidyr::pivot_longer( + cols = -dplyr::all_of(indexing_vars_cols), + names_to = "age", + values_to = "estimate" + ) |> + # removes the 0 so assuming there will be no recorded zero catch but Rceattle reports ages up to 117 + dplyr::filter(estimate != 0) |> + dplyr::mutate( + label = "composition_predicted", + # NOTE: the below age mutate slows down code + age = stringr::str_replace(age, "agehat_", "") + ) + + # Finish adjusting comp_obs + # pivot obs data + df_comp_obs <- df_comp_obs |> + tidyr::pivot_longer( + cols = -dplyr::all_of(indexing_vars_cols), + names_to = "age", + values_to = "estimate" + ) |> + dplyr::filter(!is.na(estimate)) |> + dplyr::mutate( + label = "composition_observed", + # NOTE: the below age mutate slows down code + age = stringr::str_replace(age, "comp_", "") + ) + + df_comp <- rbind(df_comp_obs, df_comp_pred) |> + # Match the index and catch frames: the standard names the fleet + # `fleet`, carries no `fleet_name` or `species`, and every row states + # which module it came from. + dplyr::rename(fleet = fleet_name) |> + dplyr::mutate(module_name = names(extract)) |> + dplyr::select(-dplyr::any_of("species")) |> + # TODO: do I need to filter sample size by <3 for confidentiality or does this not apply? + dplyr::select(-c(age0_length1, fleet_code, sample_size)) + + df_comp[setdiff(tolower(names(out_new)), tolower(names(df_comp)))] <- NA + data_list_list[["comp_data"]] <- df_comp + + # final df for data_list module + # rbind() rather than bind_rows(): every frame has already been padded + # to the standard column set above, so rbind() succeeds and keeps the + # column contract -- it aborts on a frame carrying an extra column, + # where bind_rows() would silently widen the output. + new_df <- Reduce(rbind, data_list_list) + out_list[[names(extract)]] <- new_df + } else if (module_name == "quantities") { + ###### quantities #### + # Only selectivity and natural mortality at age for now. Both are + # [fleet or species, sex, age, year] arrays. The age dimension is the + # bin index, so the age itself is offset by minage. + ages <- dat[["data_list"]][["minage"]] - 1 + + seq_len(dat[["data_list"]][["nages"]]) + nsex <- dat[["data_list"]][["nsex"]] + # Rceattle stores sex 1 as females, or both sexes when nsex = 1. + sex_names <- if (nsex == 1) NA_character_ else c("female", "male") + quantities_list <- list() + + if ("sel_at_age" %in% names(extract[[1]])) { + sel <- extract[[1]][["sel_at_age"]][, seq_len(nsex), seq_along(ages), , drop = FALSE] + df_sel <- expand.grid( + fleet = dimnames(sel)[[1]], + sex = sex_names, + age = ages, + year = as.numeric(dimnames(sel)[[4]]), + stringsAsFactors = FALSE + ) |> + dplyr::mutate( + estimate = as.vector(sel), + label = "sel_at_age" + ) + df_sel[setdiff(tolower(names(out_new)), tolower(names(df_sel)))] <- NA + quantities_list[["sel_at_age"]] <- df_sel + } + + if ("M_at_age" %in% names(extract[[1]])) { + m_at_age <- extract[[1]][["M_at_age"]][1, seq_len(nsex), seq_along(ages), , drop = FALSE] + df_m <- expand.grid( + sex = sex_names, + age = ages, + year = as.numeric(dimnames(m_at_age)[[4]]), + stringsAsFactors = FALSE + ) |> + dplyr::mutate( + estimate = as.vector(m_at_age), + label = "m_at_age" + ) + df_m[setdiff(tolower(names(out_new)), tolower(names(df_m)))] <- NA + quantities_list[["m_at_age"]] <- df_m + } + + if (length(quantities_list) > 0) { + out_list[[names(extract)]] <- Reduce(rbind, quantities_list) |> + dplyr::mutate( + module_name = names(extract), + age = as.character(age) + ) + } + } else if (is.list(extract[[1]])) { # indicates vector and list + ##### remaining lmnts #### + 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 + ) |> + suppressWarnings() + 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 + # remove quantities inserted from other steps + df <- df |> + dplyr::filter( + label %notin% c("index_hat", "catch_h") + ) + 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 + # rbind() as above, so a module that has drifted from the standard column + # set aborts here rather than widening the output. + 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" + ) + ) +} diff --git a/R/conout_ss3.R b/R/conout_ss3.R new file mode 100644 index 00000000..3d8eb083 --- /dev/null +++ b/R/conout_ss3.R @@ -0,0 +1,1265 @@ +conout_ss3 <- function( + file, + out_new, + fleet_names = NULL +) { + if (is.character(file)) { + # report.sso file + # read SS3 report file + dat <- utils::read.table( + file = file, + col.names = 1:get_ncol(file), + fill = TRUE, + quote = "", + colClasses = "character", # reads all data as characters + nrows = -1, + comment.char = "", + 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] + 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) + } + # 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 + keywords_start_row <- which(apply(dat, 1, function(row) any(grepl("#_KeyWords_of_tables_available_in_report_sso", row)))) + # Extract this first chunk of keywords to identify the first reported df - most likely DEFINITIONS + first_blank_after <- which(apply(dat, 1, function(row) all(is.na(row) | row == "")) & (seq_len(nrow(dat)) > keywords_start_row))[1] + rows <- c(keywords_start_row, first_blank_after) + # Extract the metric using the rows from above as a guide and clean up empty columns + keyword_1 <- dat[rows[1]:(rows[2] - 1), ] |> + replace_empty_with_na_all() + keyword_1 <- Filter(function(x) !all(is.na(x)), keyword_1)[-c(1:3), ] + colnames(keyword_1) <- c("output", "keyword", "output_order") + keyword_1 <- keyword_1 |> + dplyr::mutate(output_order = as.numeric(stringr::str_extract(output_order, "\\d+$"))) |> + dplyr::filter(output_order == 1) |> + dplyr::pull(keyword) + # 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) + colnames(keywords) <- c("output", "keyword", "output_order") + param_names <- keywords |> + 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", + "MGparm_By_Year_after_adjustments", + "CATCH", + "SPAWN_RECRUIT", + "TIME_SERIES", + "DISCARD_OUTPUT", + "INDEX_2", + "FIT_LEN_COMPS", + "FIT_AGE_COMPS", + "FIT_SIZE_COMPS", + "SELEX_database", + "Growth_Parameters", + "Kobe_Plot" + ) + std2 <- c("OVERALL_COMPS") + cha <- c("Dynamic_Bzero") + rand <- c( + "Input_Variance_Adjustment", + "SPR_SERIES", + "selparm(Size)_By_Year_after_adjustments", + "selparm(Age)_By_Year_after_adjustments", + "BIOLOGY", + "SPR/YPR_Profile", + "Biology_at_age_in_endyr", + "SPAWN_RECR_CURVE", + "PARAMETERS" + ) + info <- c( + "LIKELIHOOD", + "DEFINITIONS" + ) + aa.al <- c( + "BIOMASS_AT_AGE", + "BIOMASS_AT_LENGTH", + "DISCARD_AT_AGE", + "CATCH_AT_AGE", + "F_AT_AGE", + "MEAN_SIZE_TIMESERIES", + "NUMBERS_AT_AGE", + "NUMBERS_AT_LENGTH", + "AGE_SELEX", + "LEN_SELEX", + "MEAN_BODY_WT(Begin)", + "Natural_Mortality" + ) + nn <- c( + "MORPH_INDEXING", + "EXPLOITATION", + "DISCARD_SPECIFICATION", + "INDEX_1", + "MEAN_BODY_WT_OUTPUT" + ) + # Intentionally left empty + single_val <- c() + } else { + # r4ss::ss_output + dat <- file + # Extract fleet names + if (is.null(fleet_names)) { + fleet_names <- dat$FleetNames + } + # Output fleet names in console + cli::cli_alert_info("Identified fleet names:") + cli::cli_alert_info("{fleet_names}") + + # Extract start year and end year + start_year <- file$startyr + end_year <- file$endyr + + param_names <- names(dat) + + std <- c( + "recruit", # STD + "exploitation", # STD + "catch", # STD + "timeseries", # STD + "discard", # STD + "kobe", # maybe STD + "cpue", # STD + "derived_quants", # STD + "Dynamic_Bzero", # STD + "len_comp_fit_table", # STD + "age_comp_fit_table" # STD + ) + rand <- c( + "SPAWN_RECRUIT_CURVE", # RAND + "sprseries", # RAND + "parameters" # RAND + # "equil_yeild", # SKIP FOR NOW - RAND + ) + aa.al <- c( + "sizeselex", # AA.AL + "ageselex", # AA.AL + "Natural_Mortality", # AA.AL + "fatage", # AA.AL + "natage", # AA.AL + "batage", # AA.AL + "natlen", # AA.AL + "batlen", # AA.AL + "discard_at_age", # AA.AL + "catage", # AA.AL + "Z_at_age", # AA.AL - DO WE NEED BOTH? THIS AND Z_BY_AREA + "M_at_age", # AA.AL - DO WE NEED BOTH? THIS AND M_BY_AREA + "Z_by_area", # AA.AL + "M_by_area" # AA.AL + ) + # "growth_series" # ? UNSURE THIS IS NULL IN EXAMPLE + # "mngwt" # ??? + single_val <- c( + "sprtarg", # single value + "btarg", # single value + "SBzero" # SINGLE VALUE + ) + # ntentionally empty + std2 <- c() + cha <- c() + info <- c() + } + + # 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 + factors <- c( + "era", "year", "fleet", + "fleet_name", "age", "sex", + "area", "seas", "season", + "time", "era", "subseas", + "subseason", "platoon", "platoo", + "growth_pattern", "gp", "month", + "like", "morph", "bio_pattern", + "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 #### + for (i in seq_along(param_names)) { + # Processing data frame + parm_sel <- param_names[i] + if (parm_sel %in% c(std, std2, cha, rand, info, aa.al, single_val)) { + 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( + label = parm_sel, + module_name = parm_sel, + estimate = extract[[1]] + ) + df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA + out_list[[parm_sel]] <- df + } else { + miss_parms <- c(miss_parms, parm_sel) + cli::cli_alert(glue::glue("Skipped {parm_sel}")) + next + } + } else { + ##### STD #### + # 1,4,10,17,19,36 + if (parm_sel %in% std) { + if (is.character(file)) { + # remove first row - naming + df1 <- extract[-1, ] + # Find first row without NAs = headers + # temp fix for catch df - I have only seen this issue for Hake example + if (any(is.na(df1[1, ])) & parm_sel == "CATCH") { + df1 <- df1[-1, ] + 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 + } else { + df2 <- df1[stats::complete.cases(df1), ] + } + if (any(c("#") %in% df2[, 1])) { + full_row <- which(apply(df1, 1, function(row) is.na(row) | row == " " | row == "-" | row == "#"))[1] + df1 <- df1[-full_row[1], ] + df1 <- Filter(function(x) !all(is.na(x)), df1) + df2 <- df1[stats::complete.cases(df1), ] + } + # identify first row + row <- df2[1, ] + # find row number that matches 'row' + rownum <- row_match(as.vector(row), df1) + # make row the header names for first df + colnames(df1) <- row + # Subset data frame + df3 <- df1[-c(1:rownum), ] + colnames(df3) <- tolower(row) + } else { + # from 4rss output + df3 <- extract + colnames(df3) <- tolower(colnames(df3)) + # ID any column names that are fleets (exploitation module in r4ss) + if (any(tolower(fleet_names) %in% colnames(df3))) { + for (i in intersect(tolower(fleet_names), colnames(df3))) { + col_name <- glue::glue("exploitation_{i}") + df3 <- df3 |> + dplyr::rename(!!col_name := i) + } + } + } + # Remove any leftover NA columns if still present + NA_cols <- which(sapply(df3, function(x) all(is.na(x)))) + if (length(NA_cols) > 0) df3 <- df3[, -NA_cols] + # Remove suprper + use from df + if (any(grepl("suprper|use", colnames(df3)))) { + df3 <- df3 |> + dplyr::select(-tidyselect::any_of(c("suprper", "use"))) + } + # Reformat data frame + if (any(colnames(df3) %in% c("Yr", "yr"))) { + df3 <- df3 |> + dplyr::rename(year = yr) + } + if ("label" %in% colnames(df3)) { + if (any(grepl("_[0-9]+$", df3$label))) { + df4 <- df3 |> + dplyr::mutate( + year = stringr::str_extract(label, "[0-9]+$"), + label = stringr::str_remove(label, "_[0-9]+$"), + # Add factors consistent with other else + area = NA, + sex = NA, + growth_pattern = NA, + fleet = NA + ) # need to remove the multiple error one + } + } 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 + dplyr::mutate(sex = if (any(grepl("^sexes$", colnames(df3)))) sexes else NA) |> + dplyr::select(-sexes) + } 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 + if (length(err_col_id) > 0) { + uncert_name <- stringr::str_extract(err_col_id, paste0(errors, collapse = "|")) + df3 <- df3 |> + dplyr::rename(!!uncert_name := err_col_id) + } + df4 <- df3 |> + tidyr::pivot_longer( + !tidyselect::any_of(c(factors, errors)), + names_to = "label", + values_to = "estimate" + ) |> # , colnames(dplyr::select(df3, tidyselect::matches(errors))) + dplyr::mutate( + fleet = if ("fleet" %notin% colnames(df3)) { + dplyr::case_when( + # "fleet" %in% colnames(.data) ~ fleet, + grepl(paste0(tolower(fleet_names), collapse = "|"), label) ~ stringr::str_extract(label, paste(tolower(fleet_names), collapse = "|")), + grepl(":_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), + grepl(":_[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9][0-9]+"), + TRUE ~ NA + ) + } else if ("fleet_name" %in% colnames(df3)) { + fleet_name + } else { + fleet + }, + area = if ("area" %notin% colnames(df3)) { + dplyr::case_when( + grepl("?_area_[0-9]_?", label) ~ stringr::str_extract(label, "(?<=area_)[0-9]+"), + grepl("_[0-9]_", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), + grepl(":_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), + grepl(":_[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9][0-9]+"), + TRUE ~ NA + ) + } else { + area + }, + sex = if ("sex" %notin% colnames(df3)) { + dplyr::case_when( + grepl("_fem_", label) ~ "female", + grepl("_mal_", label) ~ "male", + grepl("_sx:1$", label) ~ "female", + grepl("_sx:2$", label) ~ "male", + grepl("_sx:1_", label) ~ "female", + grepl("_sx:2_", label) ~ "male", + TRUE ~ NA + ) + } else { + dplyr::case_when( + sex == 1 ~ "female", + sex == 2 ~ "male", + sex == 3 ~ "both", + sex == 0 ~ "combined", + TRUE ~ as.character(sex) + ) + }, + growth_pattern = dplyr::case_when( + grepl("_gp_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]$"), + grepl("_gp:[0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9]$"), + grepl("_gp:[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9][0-9]$"), + 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 + ) + } + ) + + df4 <- df4 |> + dplyr::mutate( + label = dplyr::case_when( + grepl("?_month_[0-9]_?", label) ~ stringr::str_replace(label, "_?month_\\d?", ""), + grepl("?_area_[0-9]_?", label) ~ stringr::str_replace(label, "_?area_\\d?", ""), + grepl(paste0(tolower(fleet_names), collapse = "|"), label) ~ stringr::str_remove(label, paste0("_", tolower(fleet_names), collapse = "|")), + TRUE ~ stringr::str_extract(label, "^.*?(?=_\\d|_gp|_fem|_mal|_sx|:|$)") + ) + ) + + if (parm_sel == "DISCARD_OUTPUT") { + df4 <- df4 |> + dplyr::mutate(label = glue::glue("discard_{label}")) + } + # } + } else { + 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] + if (any(grepl("sel", err_names))) { + df4 <- df4 + } else if (length(intersect(errors, colnames(df4))) == 1 && "raw_dev" %notin% unique(df4$label)) { + df4 <- df4[-grep(paste(errors, "_", collapse = "|", sep = ""), df4$label), ] + } else if (parm_sel == "MGparm_By_Year_after_adjustments") { # this is too specific + df4 <- df4 + cli::cli_alert_info("Error values are present, but are unique to the data frame and not to a selected parameter.") + } else { + # remove dev and raw_dev from output -- no place for it atm + if ("raw_dev" %in% unique(df4$label)) { + df4 <- df4 |> dplyr::filter(label != "raw_dev") + err_names <- err_names[-grep("raw_dev", err_names)] + } + if ("dev" %in% unique(df4$label)) { + df4 <- df4 |> dplyr::filter(label != "dev") + } + df4 <- df4 |> + tidyr::pivot_wider( + names_from = label, + values_from = estimate, + id_cols = c(intersect(colnames(df4), factors)), + values_fill = NA + ) |> + tidyr::pivot_longer( + cols = -c(intersect(colnames(df4), factors), err_names), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::select(tidyselect::any_of(c("label", "estimate", factors, errors, err_names))) + if (length(err_names) > 1) { + # warning("There are multiple reported error metrics.") + if (any(grepl(paste(err_names, collapse = "|"), colnames(df4)))) { + df4 <- df4 |> + dplyr::select(-tidyselect::all_of(err_names[2:length(err_names)])) + cli::cli_alert_info( + glue::glue("Multiple error metrics reported in {parm_sel}.") + ) + cli::cli_alert_info( + glue::glue("Error label(s) removed: \n {paste(err_names[-1], sep = '\n')}") + ) + } else { + df4 <- df4 |> + dplyr::filter(!(label %in% err_names[2:length(err_names)])) + } + # Find overlapping error values if still present + find_error_value <- function(column_names, to_match_vector) { + vals <- vapply(column_names, function(col_name) { + match <- vapply(to_match_vector, function(err) { + pattern <- paste0("(^|[_.])", err, "($|[_.])") + if (grepl(pattern, col_name)) err else NA_character_ + }, FUN.VALUE = character(1)) + stats::na.omit(match)[1] + }, FUN.VALUE = character(1)) + # } + # only unique values and those that intersect with values vector + intersect(unique(vals), to_match_vector) + } + # SS: I am not entirely sure what this step is doing, but is a good check + if (any(grepl(paste(err_names, collapse = "|"), colnames(df4)))) { + err_name <- find_error_value(names(df4), errors) + if (length(err_name) > 1) { + err_name <- stringr::str_extract(err_names[1], paste(errors, collapse = "|")) + # cli::cli_alert_info( + # glue::glue("Multiple error metrics reported in {parm_sel}. Error label(s) removed: {err_names[-1]}" + # ) + # ) + } + colnames(df4)[grepl(err_name, colnames(df4))] <- err_name + } else { + err_name <- find_error_value(unique(df4$label), errors) + colnames(df4)[grepl(paste(errors, collapse = "|"), colnames(df4))] <- err_name + } + } + } + } + + df5 <- df4 |> + dplyr::select(tidyselect::any_of(c("label", "estimate", "year", factors, errors))) |> + dplyr::mutate( + module_name = parm_sel, + label = dplyr::case_when( + label == "f" ~ "fishing_mortality", + TRUE ~ label + ), + estimate = suppressWarnings(as.numeric(estimate)) + # dplyr::if_else( + # grepl("-|_", as.numeric(estimate)), + # NA, + # estimate + # ) + ) + + if (any(colnames(df5) %in% errors)) { + df5 <- df5 |> + dplyr::mutate(uncertainty_label = intersect(names(df5), errors)) |> + dplyr::rename(uncertainty = intersect(colnames(df5), errors)) + colnames(df5) <- tolower(names(df5)) + } else { + df5 <- df5 |> + dplyr::mutate( + uncertainty_label = NA, + uncertainty = NA + ) + 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)) + cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) + # warning(parm_sel, " has more columns than the output data frame. The column(s) ", paste(diff, collapse = ", ")," are not found in the standard file. It was excluded from the resulting output. Please open an issue for developer fix.") + df5 <- dplyr::select(df5, -tidyselect::all_of(c(diff))) + out_list[[parm_sel]] <- df5 + } else { + out_list[[parm_sel]] <- df5 + } + ##### STD2 #### + } else if (parm_sel %in% std2) { + # 4, 8 + # remove first row - naming + df1 <- extract[-1, ] + # check for age and length comps + rows <- df1 |> dplyr::filter_all(dplyr::any_vars(. %in% c("age_bins", "len_bins"))) + if (length(rows) > 1) { + matchr <- row_match(rows, df1) + df1a <- df1[matchr[1]:matchr[2] - 1, ] + df1a <- Filter(function(x) !all(is.na(x)), df1a) + df1b <- df1[matchr[2]:nrow(df1), ] + df1b <- Filter(function(x) !all(is.na(x)), df1b) + df_list <- list(df1a, df1b) + } else { + # Find first row without NAs = headers + df_sel <- df1[stats::complete.cases(df1), ] + df_list <- list(df_sel) + } + comps_list <- list() + for (i in seq_along(df_list)) { + df2 <- df_list[[i]] + # identify first row + row <- tolower(df2[1, ]) + # make row the header names for first df + colnames(df2) <- row + df2 <- df2[-1, ] + # Defining columns for the grouping + if (any(grepl("len_bins", colnames(df2)))) { + std2_id <- "len_bins" + } else if (any(grepl("age_bins", colnames(df2)))) { + std2_id <- "age_bins" + } else { + std2_id <- "fleet" + } + # pivot data + if (any(grepl(":", df2[max(nrow(df2)), ]))) { + df2 <- df2[-max(nrow(df2)), ] + } else { + df2 <- df2 + } + df3 <- df2 |> + tidyr::pivot_longer( + cols = -intersect(c(factors, errors, std2_id, "n_obs"), colnames(df2)), + names_to = "label", + values_to = "estimate" + ) |> + tidyr::pivot_wider( + names_from = tidyselect::all_of(std2_id), + values_from = estimate + ) + # if(!std2_id %in% factors){ + colnames(df3) <- stringr::str_replace(colnames(df3), "label", std2_id) + # } + if (any(duplicated(tolower(names(df3))))) { + repd_name <- names(which(table(tolower(names(df3))) > 1)) + df3 <- df3 |> + dplyr::select(-tidyselect::all_of(repd_name)) + colnames(df3) <- tolower(names(df3)) + } + if ("age_bins" %in% colnames(df3)) df3 <- dplyr::rename(df3, age = age_bins) + if (nrow(df3) > 0) { + df4 <- df3 |> + tidyr::pivot_longer( + cols = -intersect(c(factors, errors, std2_id, "n_obs"), colnames(df3)), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate(module_name = parm_sel) + } else { + df4 <- df3 + } + if ("seas" %in% colnames(df4)) { + df4 <- df4 |> + dplyr::rename(season = seas) + } + df4 <- dplyr::mutate(df4, module_name = parm_sel) + df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA + if (ncol(out_new) < ncol(df4)) { + diff <- setdiff(names(df4), names(out_new)) + cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) + # warning(parm_sel, " has more columns than the output data frame. The column(s) ", paste(diff, collapse = ", ")," are not found in the standard file. It was excluded from the resulting output. Please open an issue for developer fix.") + df4 <- dplyr::select(df4, -tidyselect::all_of(diff)) + } + comps_list[[i]] <- df4 + } + # 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 + area_row <- which(apply(extract, 1, function(row) any(row == "Area:"))) + area_val <- c(t(extract[area_row, 3:ncol(extract)])) + gp_row <- which(apply(extract, 1, function(row) any(row == "GP:"))) + gp_val <- c(t(extract[gp_row, 3:ncol(extract)])) + df1 <- extract[-c(1:4), ] + col_name_repl <- paste(parm_sel, "_", area_val, "_", gp_val, sep = "") + colnames(df1) <- c("year", "era", col_name_repl) + df2 <- df1 |> + tidyr::pivot_longer( + cols = -intersect(colnames(df1), c(factors, errors)), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::mutate( + area = stringr::str_extract(label, "(?<=_)[0-9]+"), + growth_pattern = stringr::str_extract(label, "(?<=_)[0-9]+$"), + label = stringr::str_extract(label, "^.*?(?=_[0-9]+)"), + module_name = parm_sel + ) + df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + if (ncol(out_new) < ncol(df2)) { + diff <- setdiff(names(df2), names(out_new)) + cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) + df2 <- dplyr::select(df2, -tidyselect::all_of(diff)) + out_list[[parm_sel]] <- df2 + } else { + out_list[[parm_sel]] <- df2 + } + ##### rand #### + } else if (parm_sel %in% rand) { + # KEYWORDS in RAND + # "Input_Variance_Adjustment" + # "SPR_SERIES" + # "selparm(Size)_By_Year_after_adjustments" + # "selparm(Age)_By_Year_after_adjustments" + # "BIOLOGY" + # "SPR/YPR_Profile" + # "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 + # set labels to "fitted_line_x" + # remove first row - naming + # df1 <- extract[-1, ] + # # Find first row without NAs = headers + # df2 <- df1[stats::complete.cases(df1), ] + # # identify first row + # 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 + # df3 <- df1[-c(1:rownum), ] + # colnames(df3) <- tolower(row) + # # add year and manipulate df + # # Extract first year of recruitment + # fyr_row <- which(apply(dat, 1, function(row) any(row == "Start_year:"))) + # first_year <- dat[fyr_row,2] + # # Extract last year + # endyr_row <- which(apply(dat, 1, function(row) any(row == "End_year:"))) + # end_year <- dat[endyr_row,2] + # df4 <- df3 |> + # dplyr::mutate( + # year = seq(first_year, end_year, by = 1), + # ) + # skipping for now cuz not needed + miss_parms <- c(miss_parms, parm_sel) + next + } else if (parm_sel %in% c("sprseries", "SPR_SERIES")) { + if (is.character(file)) { + # split into the 3 dfs then stack - make sure all factors are present + # remove first row - naming + df1 <- extract[-1, ] + # Find first row without NAs = headers + df2 <- df1[stats::complete.cases(df1), ] + # identify first row + 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 + df3 <- df1[-(1:rownum), ] + colnames(df3) <- tolower(row) + } else { + df3 <- extract + colnames(df3) <- tolower(colnames(df3)) + } + # check if there are estimate and acual values within the df + if (any(grepl("actual", colnames(df3)) | grepl("more_f", colnames(df3)))) { + actual_col <- grep("actual", colnames(df3)) + moref_col <- grep("more_f", colnames(df3)) + # Separate out parts of the dataframe + sub_df1 <- df3[, 1:(actual_col - 1)] |> + tidyr::pivot_longer( + cols = -c(yr, era), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::rename(year = yr) |> + dplyr::mutate( + label = dplyr::case_when( + label == "bio_all" ~ "biomass", + label == "bio_smry" ~ "biomass_midyear", + label == "ssbzero" ~ "spawning_biomass_zero", + # label == "ssbfished" ~ "spawning_biomass", + label == "ssbfished/r" ~ "ssbfished_r", + TRUE ~ label + ), + # 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), + names_to = "label", + values_to = "initial" + ) |> + dplyr::rename(year = yr) |> + dplyr::mutate( + label = dplyr::case_when( + label == "bio_all" ~ "biomass", + label == "bio_smry" ~ "biomass_midyear", + label == "num_smry" ~ "abundance_midyear", + label == "dead_catch" ~ "total_catch", # dead + retained + label == "retain_catch" ~ "landings", + label == "ssb" ~ "spawning_biomass", + label == "recruits" ~ "recruitment", + TRUE ~ label + ), + # change so that the values are placed in the column "initial" then combine w/ estimates + # label = paste("actual_", label, sep = ""), + morph = NA + ) + # combine above 2 since they show the estimate and actual values - matching + sub_df12 <- dplyr::full_join( + sub_df1, + sub_df2, + by = c("year", "era", "label", "morph") + ) + # extract last part of df + sub_df3 <- df3[, c(1:2, (moref_col + 1):ncol(df3))] |> + tidyr::pivot_longer( + cols = -c(yr, era), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::rename(year = yr) |> + dplyr::mutate( + morph = dplyr::case_when( + grepl("avef_|maxf_", label) ~ stringr::str_extract(label, "[0-9]+$"), + TRUE ~ NA_character_ + ), + label = dplyr::case_when( + grepl("avef_", label) ~ stringr::str_remove(label, "_[0-9]+"), + grepl("maxf_", label) ~ stringr::str_remove(label, "_[0-9]+"), + label == "f=z-m" ~ "fishing_mortality", + TRUE ~ label + ), + initial = NA + ) + # combine all subdataframes + df4 <- rbind(sub_df12, sub_df3) |> + dplyr::mutate(module_name = parm_sel) + } else { + df4 <- df3 |> + tidyr::pivot_longer( + cols = -c(intersect(colnames(df3), c("Yr", "yr", "era"))), + names_to = "label", + values_to = "estimate" + ) |> + dplyr::rename(year = intersect(colnames(df3), c("Yr", "yr", "Year"))) |> + dplyr::mutate( + label = dplyr::case_when( + grepl("bio_all", label) ~ "biomass", + grepl("bio_smry", label) ~ "biomass_midyear", + label == "ssbzero" ~ "spawning_biomass_zero", + # label == "ssbfished" ~ "spawning_biomass", + grepl("SSB_unfished", label) ~ "SSB_unfished", + grepl("SSBfished_eq", label) ~ "SSB_fished", + label == "ssbfished/r" ~ "ssbfished_r", + TRUE ~ label + ), + # label = paste("estimate_", label, sep = ""), + morph = NA, + module_name = parm_sel + ) + } + # match to out_new + df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA + # Add to out list + out_list[[parm_sel]] <- df4 + } else if (parm_sel == "selparm(Size)_By_Year_after_adjustments") { + # TODO: revisit one day in group work + # skipping this one because there are no headers + miss_parms <- c(miss_parms, parm_sel) + next + } else if (parm_sel == "selparm(Age)_By_Year_after_adjustments") { + # also skipping + miss_parms <- c(miss_parms, parm_sel) + next + } else if (parm_sel == "BIOLOGY") { + # not sure how this output is helpful + miss_parms <- c(miss_parms, parm_sel) + next + } else if (parm_sel == "SPR/YPR_Profile") { + miss_parms <- c(miss_parms, parm_sel) + next + } else if (parm_sel == "Biology_at_age_in_endyr") { + miss_parms <- c(miss_parms, parm_sel) + next + } else if (tolower(parm_sel) == "parameters") { + if (is.character(file)) { + df1 <- extract[-1, ] + # Find first row without NAs = headers + # temp fix for catch df + df2 <- df1[stats::complete.cases(df1), ] + if (any(c("#") %in% df2[, 1])) { + full_row <- which(apply(df1, 1, function(row) is.na(row) | row == " " | row == "-" | row == "#"))[1] + df1 <- df1[-full_row[1], ] + df1 <- Filter(function(x) !all(is.na(x)), df1) + df2 <- df1[stats::complete.cases(df1), ] + } + # identify first row + 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 + df3 <- df1[-c(1:rownum), ] + colnames(df3) <- tolower(row) + } else { + df3 <- extract + colnames(df3) <- tolower(colnames(df3)) + } + # Pull out indexing variables and remove from labels + df4 <- df3 |> + dplyr::select(intersect(colnames(df3), c("label", "value", "init", "parm_stdev"))) |> + dplyr::rename( + estimate = value, + initial = init, + uncertainty = parm_stdev + ) |> + dplyr::mutate( + uncertainty = dplyr::case_when( + uncertainty == "_" ~ NA, + TRUE ~ uncertainty + ), + uncertainty_label = dplyr::case_when( + is.na(uncertainty) ~ NA, + TRUE ~ "sd" + ), + area = dplyr::case_when( + grepl("?_area_[0-9]_?", label) ~ stringr::str_extract(label, "(?<=area_)[0-9]+"), + grepl("_[0-9]_", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), + grepl(":_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), + grepl(":_[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9][0-9]+"), + TRUE ~ NA + ), + sex = dplyr::case_when( + grepl("_fem_", label) ~ "female", + grepl("_mal_", label) ~ "male", + grepl("_sx:1$", label) ~ "female", + grepl("_sx:2$", label) ~ "male", + grepl("_sx:1_", label) ~ "female", + grepl("_sx:2_", label) ~ "male", + grepl("Male", label) ~ "male", + grepl("Female", label) ~ "female", + TRUE ~ NA + ), + growth_pattern = dplyr::case_when( + grepl("_gp_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]$"), + grepl("_gp:[0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9]$"), + grepl("_gp:[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9][0-9]$"), + grepl("_GP_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]$"), + grepl("_GP:[0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9]$"), + grepl("_GP:[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9][0-9]$"), + TRUE ~ NA + ), + month = dplyr::case_when( + grepl("_month_[0-9]+$", label) ~ stringr::str_extract(label, "(?<=month_)[0-9]+$"), + TRUE ~ ifelse(any(grepl("^month$", colnames(df3))), month, NA) + ), + age = dplyr::case_when( + grepl("InitAge", label) ~ stringr::str_extract(label, "(?<=InitAge_)[0-9]+"), + TRUE ~ NA + ), + year = dplyr::case_when( + grepl("RecrDev", label) ~ stringr::str_extract(label, "(?<=RecrDev_)[0-9]+$"), + grepl("_[0-9]{4}$", label) ~ stringr::str_extract(label, "[0-9]{4}$"), + TRUE ~ NA + ), + era = dplyr::case_when( + grepl("InitAge", label) ~ stringr::str_extract(label, "^.*?(?=_InitAge_[0-9]+$)"), + grepl("RecrDev", label) ~ stringr::str_extract(label, "^.*?(?=_RecrDev)"), + TRUE ~ NA + ), + fleet = dplyr::case_when( + grepl( + paste( + fleet_names, + collapse = "|" + ), + label + ) ~ stringr::str_extract(label, paste0("(^.*?_)?<=|", paste(fleet_names, collapse = "|"))), + TRUE ~ NA + ), + block = dplyr::case_when( + grepl("_BLK[0-9]repl_[0-9]{4}$", label) ~ stringr::str_extract(label, "(?<=_BLK)[0-9](?=repl_[0-9]{4}$)"), + TRUE ~ NA + ), + # Must be last step in mutate bc all info comes from the + label = dplyr::case_when( + grepl("?_month_[0-9]_?", label) ~ stringr::str_replace(label, "_?month_\\d?", ""), + grepl("?_area_[0-9]_?", label) ~ stringr::str_replace(label, "_?area_\\d?", ""), + grepl("InitAge", label) ~ "initial_age", + grepl("RecrDev", label) ~ "recruitment_deviations", + grepl( + paste0( + paste0( + "_", + fleet_names, + collapse = "|" + ), + "\\([0-9]+\\)_BLK[0-9]repl_[0-9]{4}$" + ), + label + ) ~ stringr::str_remove_all(label, "(Male_|Female_)|(_[[:alnum:]]+\\([0-9]+\\))|(_BLK[0-9]repl_[0-9]{4})"), + grepl("Male_|Female_", label) & grepl(paste0(paste0("_", fleet_names, collapse = "|"), "\\([0-9]+\\)"), label) ~ stringr::str_remove_all(label, "(Male_|Female_)|(_[[:alnum:]]+\\([0-9]+\\))"), + grepl(paste0(paste0("_", fleet_names, collapse = "|"), "\\([0-9]+\\)"), label) ~ stringr::str_remove(label, paste0(paste0("_", fleet_names, "\\([0-9]+\\)", collapse = "|"))), # , paste0("_", fleet_names, collapse = "|") + TRUE ~ stringr::str_extract(label, "^.*?(?=_\\d|_gp|_fem|_mal|_sx|:|$)") + ), + # fix remaining labels + label = ifelse(grepl("_GP$", label), stringr::str_remove(label, "_GP$"), label), + label = ifelse(grepl("_Fem|_Mal", label), stringr::str_remove(label, "_Fem$|_Mal$"), label), + label = ifelse(grepl(paste0(fleet_names, collapse = "|"), label), stringr::str_remove(label, paste0("_", fleet_names, collapse = "|")), label), + module_name = parm_sel + ) + # match to out_new + df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA + # Add to out list + out_list[[parm_sel]] <- df4 + } else { + miss_parms <- c(miss_parms, parm_sel) + next + } + # miss_parms <- c(miss_parms, parm_sel) + # next + #### info #### + } else if (parm_sel %in% info) { + # if (parm_sel == "LIKELIHOOD") { + # df1 <- extract[-1, ] + # # make row the header names for first df + # colnames(df1) <- df1[1, ] + # # Remove first row containing column names + # df2 <- df1[-1, ] |> + # dplyr::rename(label = Component) |> + # tidyr::pivot_longer( + # cols = -label, + # names_to = "type", + # values_to = "likelihood" + # ) + # # match to out_new + # df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + # # Add to out list + # out_list[[parm_sel]] <- df2 + # } else + if (parm_sel == "DEFINITIONS") { + # Extract start year and end year for iding era + start_year <- as.numeric(extract[which(apply(extract, 1, function(row) any(row == "Start_year:"))), 2]) + end_year <- as.numeric(extract[which(apply(extract, 1, function(row) any(row == "End_year:"))), 2]) + # Pull out only the first two columns and remove first row keyword + # df1 <- extract[-1, 1:2] + # colnames(df1) <- c("label", "estimate") + # # find where rescale is located + # col_rescale <- grep("rescaled_to_sum_to:", extract) + # rescaled_months <- extract[4, col_rescale + 1] |> dplyr::pull() + # # remove : from all labels and tolower and add in rescaled months + # df2 <- df1 |> + # rbind(data.frame( + # label = "rescaled_months", + # estimate = rescaled_months + # )) |> + # dplyr::mutate( + # label = tolower(stringr::str_remove_all(label, ":")), + # module_name = parm_sel + # ) + # # match to out_new + # df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA + # # Add to out list + # out_list[[parm_sel]] <- df2 + } else { + miss_parms <- c(miss_parms, parm_sel) + next + } + #### aa.al #### + } else if (parm_sel %in% aa.al) { + # 8,9,11,12,13,14,15,16,28,29 + if (is.character(file)) { + # remove first row - naming + df1 <- extract[-1, ] + # Find first row without NAs = headers + df2 <- df1[stats::complete.cases(df1), ] + # identify first row + row <- df2[1, ] + if (any(row %in% "XX")) { + loc_xx <- grep("XX", row) + 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 <- 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 <- row_match(row, df1) + # Subset data frame + df3 <- df1[-c(1:rownum), ] + colnames(df3) <- tolower(row) + } else { + # Remove XX columns left in dataframe + if (any("xx" %in% tolower(colnames(extract)))) { + # ID which cols contain XX + df3 <- extract[, -grep("xx", tolower(colnames(extract)))] + } else { + df3 <- extract + } + colnames(df3) <- tolower(colnames(df3)) + } + # aa.al names + naming <- c( + "biomass", "discard", "catch", + "f", "mean_size", "numbers", "Lsel", "sel", + "mean_body_wt", "natural_mortality" + ) + if (stringr::str_detect(tolower(parm_sel), paste(naming, collapse = "|"))) { + label <- stringr::str_extract(tolower(parm_sel), paste(naming, collapse = "|")) + if (length(label) > 1) cli::cli_alert_warning("Length of label is > 1.") + 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" + ) + ) + } + if (grepl("age", tolower(parm_sel))) { + fac <- "age" + } else if (any(grepl("length|len", tolower(parm_sel)))) { + fac <- "len_bins" + } else if (any(grepl("size", tolower(parm_sel)))) { + fac <- "len_bins" + } 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 |> + dplyr::rename(year = yr) + } + if (any(colnames(df3) %in% c("seas"))) { + df3 <- df3 |> + dplyr::rename(season = seas) + } + if (any(colnames(df3) %in% c("subseas"))) { + df3 <- df3 |> + dplyr::rename(subseason = subseas) + } + # if ("label" %in% colnames(df3)) { + # df3 <- dplyr::select(df3, -tidyselect::any_of("label")) + # } + # If factor exists, set to label + if ("factor" %in% colnames(df3)) { + df3 <- df3 |> + dplyr::select(-tidyselect::any_of("label")) |> + dplyr::rename(label = factor) + } else if ("type" %in% colnames(df3)) { + df3 <- df3 |> + dplyr::mutate(label = glue::glue("{label}_{type}")) |> + dplyr::select(-type) + } else { + df3 <- dplyr::mutate(df3, label = label[1]) + } + # Change all columns to chatacters to a avoid issues in pivoting - this will be changed in final df anyway + df3 <- df3 |> + dplyr::mutate(dplyr::across(tidyselect::everything(), as.character)) + # Set all columns after factors as numeric + # Identify last factor col + other_factors <- c( + "bio_pattern", "birthseas", + "settlement", "morph", "beg/mid", + "type", "label", "label", + "platoon", "month", + "sexes", "part", "bin", "kind" + ) + num_cols <- setdiff(colnames(df3), c(factors, other_factors)) + df3 <- df3 |> + dplyr::mutate(dplyr::across(dplyr::all_of(num_cols), as.numeric)) + # Pivot table long + df4 <- df3 |> + tidyr::pivot_longer( + cols = -intersect(c(factors, errors, other_factors), colnames(df3)), + names_to = fac[1], + values_to = "estimate" + ) |> + dplyr::mutate( + # label = label[1], + module_name = parm_sel[1] + ) + if ("sex" %in% colnames(df4)) { + df4 <- df4 |> + dplyr::mutate( + sex = dplyr::case_when( + "sex" %in% colnames(df3) & sex == 1 ~ "female", + "sex" %in% colnames(df3) & sex == 2 ~ "male" + ) + ) + } + if (any(grepl("morph", colnames(df4)))) { + df4 <- df4 |> + dplyr::rename(growth_pattern = morph) + } + # Check if likelihood is in the df + if (any(grepl("like", colnames(df4)))) { + df4 <- df4 |> + dplyr::rename(likelihood = like) + } + # Rename beg/mid if present + if (any(grepl("beg/mid", colnames(df4)))) { + df4 <- df4 |> + dplyr::rename(beg_mid = "beg/mid") + } + # Check for error in the df + if (any(grepl(paste0("^", errors, "$", collapse = "|"), colnames(df4)))) { + error_col <- colnames(df4)[grep(paste0("^", errors, "$", collapse = "|"), colnames(df4))] + if (length(error_col) > 1) { + cli::cli_alert("Multiple error columns present. Error will not be added to module.") + } else { + df4 <- df4 |> + dplyr::mutate( + uncertainty_label = tolower(unique(error_col)), + uncertainty = df4[[error_col]] + ) + } + } + if ("label" %in% colnames(df4) & "factor" %in% colnames(df4)) { + df4 <- df4 |> + dplyr::select(-label) |> + dplyr::mutate(label = dplyr::case_when( + grepl("sel", factor) ~ "sel", + TRUE ~ factor + )) |> + dplyr::select(-factor) + } + # Bind to new df + df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA + if (ncol(out_new) < ncol(df4)) { + diff <- setdiff(names(df4), names(out_new)) + cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) + # warning(parm_sel, " has more columns than the output data frame. The column(s) ", paste(diff, collapse = ", ")," are not found in the standard file. It was excluded from the resulting output. Please open an issue for developer fix.") + df4 <- dplyr::select(df4, -tidyselect::all_of(diff)) + out_list[[parm_sel]] <- df4 + } else { + out_list[[parm_sel]] <- df4 + } + # } else if (parm_sel %in% nn) { + # miss_parms <- c(miss_parms, parm_sel) + # next + } else { + cli::cli_alert_info(glue::glue("Processing {parm_sel}")) + miss_parms <- c(miss_parms, parm_sel) + next + } + } # close if param is in output file + #### skip parm in ss3 #### + } else { + if (is.character(file)) cli::cli_alert(glue::glue("Skipped [{i}] {parm_sel}")) + next + } + } # close loop + if (length(miss_parms) > 0) { + cli::cli_alert_info( + paste0("Some parameters were not found or included in the output file. The following parameters were not added into the new output file: \n", paste(miss_parms, collapse = "\n")) + ) + } + out_new <- Reduce(rbind, out_list) + out_new |> + dplyr::mutate( + fleet = if (any(unique(out_new$fleet) %in% fleet_names)) fleet else fleet_names[fleet], + era = dplyr::case_when( + !is.na(era) ~ era, + year < start_year ~ "init", + year >= start_year & year <= end_year ~ "time", + year > end_year ~ "fore", + TRUE ~ NA_character_ + ) + ) +} diff --git a/R/convert_output.R b/R/convert_output.R index 7ff4dc61..8c7869eb 100644 --- a/R/convert_output.R +++ b/R/convert_output.R @@ -171,1780 +171,10 @@ convert_output <- function( # SS3 groupings: https://docs.google.com/spreadsheets/d/11-k0xOo3Bit1MbJf2ZjmymzsUNCRhgGkVfXV1jNEdbM/edit?gid=0#gid=0 # Convert SS3 output Report.sso file if (tolower(model) == "ss3") { - if (is.character(file)) { - # report.sso file - # read SS3 report file - dat <- utils::read.table( - file = file, - col.names = 1:get_ncol(file), - fill = TRUE, - quote = "", - colClasses = "character", # reads all data as characters - nrows = -1, - comment.char = "", - 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] - 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) - } - # 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 - keywords_start_row <- which(apply(dat, 1, function(row) any(grepl("#_KeyWords_of_tables_available_in_report_sso", row)))) - # Extract this first chunk of keywords to identify the first reported df - most likely DEFINITIONS - first_blank_after <- which(apply(dat, 1, function(row) all(is.na(row) | row == "")) & (seq_len(nrow(dat)) > keywords_start_row))[1] - rows <- c(keywords_start_row, first_blank_after) - # Extract the metric using the rows from above as a guide and clean up empty columns - keyword_1 <- dat[rows[1]:(rows[2] - 1), ] |> - replace_empty_with_na_all() - keyword_1 <- Filter(function(x) !all(is.na(x)), keyword_1)[-c(1:3), ] - colnames(keyword_1) <- c("output", "keyword", "output_order") - keyword_1 <- keyword_1 |> - dplyr::mutate(output_order = as.numeric(stringr::str_extract(output_order, "\\d+$"))) |> - dplyr::filter(output_order == 1) |> - dplyr::pull(keyword) - # 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) - colnames(keywords) <- c("output", "keyword", "output_order") - param_names <- keywords |> - 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", - "MGparm_By_Year_after_adjustments", - "CATCH", - "SPAWN_RECRUIT", - "TIME_SERIES", - "DISCARD_OUTPUT", - "INDEX_2", - "FIT_LEN_COMPS", - "FIT_AGE_COMPS", - "FIT_SIZE_COMPS", - "SELEX_database", - "Growth_Parameters", - "Kobe_Plot" - ) - std2 <- c("OVERALL_COMPS") - cha <- c("Dynamic_Bzero") - rand <- c( - "Input_Variance_Adjustment", - "SPR_SERIES", - "selparm(Size)_By_Year_after_adjustments", - "selparm(Age)_By_Year_after_adjustments", - "BIOLOGY", - "SPR/YPR_Profile", - "Biology_at_age_in_endyr", - "SPAWN_RECR_CURVE", - "PARAMETERS" - ) - info <- c( - "LIKELIHOOD", - "DEFINITIONS" - ) - aa.al <- c( - "BIOMASS_AT_AGE", - "BIOMASS_AT_LENGTH", - "DISCARD_AT_AGE", - "CATCH_AT_AGE", - "F_AT_AGE", - "MEAN_SIZE_TIMESERIES", - "NUMBERS_AT_AGE", - "NUMBERS_AT_LENGTH", - "AGE_SELEX", - "LEN_SELEX", - "MEAN_BODY_WT(Begin)", - "Natural_Mortality" - ) - nn <- c( - "MORPH_INDEXING", - "EXPLOITATION", - "DISCARD_SPECIFICATION", - "INDEX_1", - "MEAN_BODY_WT_OUTPUT" - ) - # Intentionally left empty - single_val <- c() - } else { - # r4ss::ss_output - dat <- file - # Extract fleet names - if (is.null(fleet_names)) { - fleet_names <- dat$FleetNames - } - # Output fleet names in console - cli::cli_alert_info("Identified fleet names:") - cli::cli_alert_info("{fleet_names}") - - # Extract start year and end year - start_year <- file$startyr - end_year <- file$endyr - - param_names <- names(dat) - - std <- c( - "recruit", # STD - "exploitation", # STD - "catch", # STD - "timeseries", # STD - "discard", # STD - "kobe", # maybe STD - "cpue", # STD - "derived_quants", # STD - "Dynamic_Bzero", # STD - "len_comp_fit_table", # STD - "age_comp_fit_table" # STD - ) - rand <- c( - "SPAWN_RECRUIT_CURVE", # RAND - "sprseries", # RAND - "parameters" # RAND - # "equil_yeild", # SKIP FOR NOW - RAND - ) - aa.al <- c( - "sizeselex", # AA.AL - "ageselex", # AA.AL - "Natural_Mortality", # AA.AL - "fatage", # AA.AL - "natage", # AA.AL - "batage", # AA.AL - "natlen", # AA.AL - "batlen", # AA.AL - "discard_at_age", # AA.AL - "catage", # AA.AL - "Z_at_age", # AA.AL - DO WE NEED BOTH? THIS AND Z_BY_AREA - "M_at_age", # AA.AL - DO WE NEED BOTH? THIS AND M_BY_AREA - "Z_by_area", # AA.AL - "M_by_area" # AA.AL - ) - # "growth_series" # ? UNSURE THIS IS NULL IN EXAMPLE - # "mngwt" # ??? - single_val <- c( - "sprtarg", # single value - "btarg", # single value - "SBzero" # SINGLE VALUE - ) - # ntentionally empty - std2 <- c() - cha <- c() - info <- c() - } - - # 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 - factors <- c( - "era", "year", "fleet", - "fleet_name", "age", "sex", - "area", "seas", "season", - "time", "era", "subseas", - "subseason", "platoon", "platoo", - "growth_pattern", "gp", "month", - "like", "morph", "bio_pattern", - "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 #### - for (i in seq_along(param_names)) { - # Processing data frame - parm_sel <- param_names[i] - if (parm_sel %in% c(std, std2, cha, rand, info, aa.al, single_val)) { - 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( - label = parm_sel, - module_name = parm_sel, - estimate = extract[[1]] - ) - df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA - out_list[[parm_sel]] <- df - } else { - miss_parms <- c(miss_parms, parm_sel) - cli::cli_alert(glue::glue("Skipped {parm_sel}")) - next - } - } else { - ##### STD #### - # 1,4,10,17,19,36 - if (parm_sel %in% std) { - if (is.character(file)) { - # remove first row - naming - df1 <- extract[-1, ] - # Find first row without NAs = headers - # temp fix for catch df - I have only seen this issue for Hake example - if (any(is.na(df1[1, ])) & parm_sel == "CATCH") { - df1 <- df1[-1, ] - 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 - } else { - df2 <- df1[stats::complete.cases(df1), ] - } - if (any(c("#") %in% df2[, 1])) { - full_row <- which(apply(df1, 1, function(row) is.na(row) | row == " " | row == "-" | row == "#"))[1] - df1 <- df1[-full_row[1], ] - df1 <- Filter(function(x) !all(is.na(x)), df1) - df2 <- df1[stats::complete.cases(df1), ] - } - # identify first row - row <- df2[1, ] - # find row number that matches 'row' - rownum <- row_match(as.vector(row), df1) - # make row the header names for first df - colnames(df1) <- row - # Subset data frame - df3 <- df1[-c(1:rownum), ] - colnames(df3) <- tolower(row) - } else { - # from 4rss output - df3 <- extract - colnames(df3) <- tolower(colnames(df3)) - # ID any column names that are fleets (exploitation module in r4ss) - if (any(tolower(fleet_names) %in% colnames(df3))) { - for (i in intersect(tolower(fleet_names), colnames(df3))) { - col_name <- glue::glue("exploitation_{i}") - df3 <- df3 |> - dplyr::rename(!!col_name := i) - } - } - } - # Remove any leftover NA columns if still present - NA_cols <- which(sapply(df3, function(x) all(is.na(x)))) - if (length(NA_cols) > 0) df3 <- df3[, -NA_cols] - # Remove suprper + use from df - if (any(grepl("suprper|use", colnames(df3)))) { - df3 <- df3 |> - dplyr::select(-tidyselect::any_of(c("suprper", "use"))) - } - # Reformat data frame - if (any(colnames(df3) %in% c("Yr", "yr"))) { - df3 <- df3 |> - dplyr::rename(year = yr) - } - if ("label" %in% colnames(df3)) { - if (any(grepl("_[0-9]+$", df3$label))) { - df4 <- df3 |> - dplyr::mutate( - year = stringr::str_extract(label, "[0-9]+$"), - label = stringr::str_remove(label, "_[0-9]+$"), - # Add factors consistent with other else - area = NA, - sex = NA, - growth_pattern = NA, - fleet = NA - ) # need to remove the multiple error one - } - } 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 - dplyr::mutate(sex = if (any(grepl("^sexes$", colnames(df3)))) sexes else NA) |> - dplyr::select(-sexes) - } 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 - if (length(err_col_id) > 0) { - uncert_name <- stringr::str_extract(err_col_id, paste0(errors, collapse = "|")) - df3 <- df3 |> - dplyr::rename(!!uncert_name := err_col_id) - } - df4 <- df3 |> - tidyr::pivot_longer( - !tidyselect::any_of(c(factors, errors)), - names_to = "label", - values_to = "estimate" - ) |> # , colnames(dplyr::select(df3, tidyselect::matches(errors))) - dplyr::mutate( - fleet = if ("fleet" %notin% colnames(df3)) { - dplyr::case_when( - # "fleet" %in% colnames(.data) ~ fleet, - grepl(paste0(tolower(fleet_names), collapse = "|"), label) ~ stringr::str_extract(label, paste(tolower(fleet_names), collapse = "|")), - grepl(":_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), - grepl(":_[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9][0-9]+"), - TRUE ~ NA - ) - } else if ("fleet_name" %in% colnames(df3)) { - fleet_name - } else { - fleet - }, - area = if ("area" %notin% colnames(df3)) { - dplyr::case_when( - grepl("?_area_[0-9]_?", label) ~ stringr::str_extract(label, "(?<=area_)[0-9]+"), - grepl("_[0-9]_", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), - grepl(":_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), - grepl(":_[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9][0-9]+"), - TRUE ~ NA - ) - } else { - area - }, - sex = if ("sex" %notin% colnames(df3)) { - dplyr::case_when( - grepl("_fem_", label) ~ "female", - grepl("_mal_", label) ~ "male", - grepl("_sx:1$", label) ~ "female", - grepl("_sx:2$", label) ~ "male", - grepl("_sx:1_", label) ~ "female", - grepl("_sx:2_", label) ~ "male", - TRUE ~ NA - ) - } else { - dplyr::case_when( - sex == 1 ~ "female", - sex == 2 ~ "male", - sex == 3 ~ "both", - sex == 0 ~ "combined", - TRUE ~ as.character(sex) - ) - }, - growth_pattern = dplyr::case_when( - grepl("_gp_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]$"), - grepl("_gp:[0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9]$"), - grepl("_gp:[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9][0-9]$"), - 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 - ) - } - ) - - df4 <- df4 |> - dplyr::mutate( - label = dplyr::case_when( - grepl("?_month_[0-9]_?", label) ~ stringr::str_replace(label, "_?month_\\d?", ""), - grepl("?_area_[0-9]_?", label) ~ stringr::str_replace(label, "_?area_\\d?", ""), - grepl(paste0(tolower(fleet_names), collapse = "|"), label) ~ stringr::str_remove(label, paste0("_", tolower(fleet_names), collapse = "|")), - TRUE ~ stringr::str_extract(label, "^.*?(?=_\\d|_gp|_fem|_mal|_sx|:|$)") - ) - ) - - if (parm_sel == "DISCARD_OUTPUT") { - df4 <- df4 |> - dplyr::mutate(label = glue::glue("discard_{label}")) - } - # } - } else { - 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] - if (any(grepl("sel", err_names))) { - df4 <- df4 - } else if (length(intersect(errors, colnames(df4))) == 1 && "raw_dev" %notin% unique(df4$label)) { - df4 <- df4[-grep(paste(errors, "_", collapse = "|", sep = ""), df4$label), ] - } else if (parm_sel == "MGparm_By_Year_after_adjustments") { # this is too specific - df4 <- df4 - cli::cli_alert_info("Error values are present, but are unique to the data frame and not to a selected parameter.") - } else { - # remove dev and raw_dev from output -- no place for it atm - if ("raw_dev" %in% unique(df4$label)) { - df4 <- df4 |> dplyr::filter(label != "raw_dev") - err_names <- err_names[-grep("raw_dev", err_names)] - } - if ("dev" %in% unique(df4$label)) { - df4 <- df4 |> dplyr::filter(label != "dev") - } - df4 <- df4 |> - tidyr::pivot_wider( - names_from = label, - values_from = estimate, - id_cols = c(intersect(colnames(df4), factors)), - values_fill = NA - ) |> - tidyr::pivot_longer( - cols = -c(intersect(colnames(df4), factors), err_names), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::select(tidyselect::any_of(c("label", "estimate", factors, errors, err_names))) - if (length(err_names) > 1) { - # warning("There are multiple reported error metrics.") - if (any(grepl(paste(err_names, collapse = "|"), colnames(df4)))) { - df4 <- df4 |> - dplyr::select(-tidyselect::all_of(err_names[2:length(err_names)])) - cli::cli_alert_info( - glue::glue("Multiple error metrics reported in {parm_sel}.") - ) - cli::cli_alert_info( - glue::glue("Error label(s) removed: \n {paste(err_names[-1], sep = '\n')}") - ) - } else { - df4 <- df4 |> - dplyr::filter(!(label %in% err_names[2:length(err_names)])) - } - # Find overlapping error values if still present - find_error_value <- function(column_names, to_match_vector) { - vals <- vapply(column_names, function(col_name) { - match <- vapply(to_match_vector, function(err) { - pattern <- paste0("(^|[_.])", err, "($|[_.])") - if (grepl(pattern, col_name)) err else NA_character_ - }, FUN.VALUE = character(1)) - stats::na.omit(match)[1] - }, FUN.VALUE = character(1)) - # } - # only unique values and those that intersect with values vector - intersect(unique(vals), to_match_vector) - } - # SS: I am not entirely sure what this step is doing, but is a good check - if (any(grepl(paste(err_names, collapse = "|"), colnames(df4)))) { - err_name <- find_error_value(names(df4), errors) - if (length(err_name) > 1) { - err_name <- stringr::str_extract(err_names[1], paste(errors, collapse = "|")) - # cli::cli_alert_info( - # glue::glue("Multiple error metrics reported in {parm_sel}. Error label(s) removed: {err_names[-1]}" - # ) - # ) - } - colnames(df4)[grepl(err_name, colnames(df4))] <- err_name - } else { - err_name <- find_error_value(unique(df4$label), errors) - colnames(df4)[grepl(paste(errors, collapse = "|"), colnames(df4))] <- err_name - } - } - } - } - - df5 <- df4 |> - dplyr::select(tidyselect::any_of(c("label", "estimate", "year", factors, errors))) |> - dplyr::mutate( - module_name = parm_sel, - label = dplyr::case_when( - label == "f" ~ "fishing_mortality", - TRUE ~ label - ), - estimate = suppressWarnings(as.numeric(estimate)) - # dplyr::if_else( - # grepl("-|_", as.numeric(estimate)), - # NA, - # estimate - # ) - ) - - if (any(colnames(df5) %in% errors)) { - df5 <- df5 |> - dplyr::mutate(uncertainty_label = intersect(names(df5), errors)) |> - dplyr::rename(uncertainty = intersect(colnames(df5), errors)) - colnames(df5) <- tolower(names(df5)) - } else { - df5 <- df5 |> - dplyr::mutate( - uncertainty_label = NA, - uncertainty = NA - ) - 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)) - cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) - # warning(parm_sel, " has more columns than the output data frame. The column(s) ", paste(diff, collapse = ", ")," are not found in the standard file. It was excluded from the resulting output. Please open an issue for developer fix.") - df5 <- dplyr::select(df5, -tidyselect::all_of(c(diff))) - out_list[[parm_sel]] <- df5 - } else { - out_list[[parm_sel]] <- df5 - } - ##### STD2 #### - } else if (parm_sel %in% std2) { - # 4, 8 - # remove first row - naming - df1 <- extract[-1, ] - # check for age and length comps - rows <- df1 |> dplyr::filter_all(dplyr::any_vars(. %in% c("age_bins", "len_bins"))) - if (length(rows) > 1) { - matchr <- row_match(rows, df1) - df1a <- df1[matchr[1]:matchr[2] - 1, ] - df1a <- Filter(function(x) !all(is.na(x)), df1a) - df1b <- df1[matchr[2]:nrow(df1), ] - df1b <- Filter(function(x) !all(is.na(x)), df1b) - df_list <- list(df1a, df1b) - } else { - # Find first row without NAs = headers - df_sel <- df1[stats::complete.cases(df1), ] - df_list <- list(df_sel) - } - comps_list <- list() - for (i in seq_along(df_list)) { - df2 <- df_list[[i]] - # identify first row - row <- tolower(df2[1, ]) - # make row the header names for first df - colnames(df2) <- row - df2 <- df2[-1, ] - # Defining columns for the grouping - if (any(grepl("len_bins", colnames(df2)))) { - std2_id <- "len_bins" - } else if (any(grepl("age_bins", colnames(df2)))) { - std2_id <- "age_bins" - } else { - std2_id <- "fleet" - } - # pivot data - if (any(grepl(":", df2[max(nrow(df2)), ]))) { - df2 <- df2[-max(nrow(df2)), ] - } else { - df2 <- df2 - } - df3 <- df2 |> - tidyr::pivot_longer( - cols = -intersect(c(factors, errors, std2_id, "n_obs"), colnames(df2)), - names_to = "label", - values_to = "estimate" - ) |> - tidyr::pivot_wider( - names_from = tidyselect::all_of(std2_id), - values_from = estimate - ) - # if(!std2_id %in% factors){ - colnames(df3) <- stringr::str_replace(colnames(df3), "label", std2_id) - # } - if (any(duplicated(tolower(names(df3))))) { - repd_name <- names(which(table(tolower(names(df3))) > 1)) - df3 <- df3 |> - dplyr::select(-tidyselect::all_of(repd_name)) - colnames(df3) <- tolower(names(df3)) - } - if ("age_bins" %in% colnames(df3)) df3 <- dplyr::rename(df3, age = age_bins) - if (nrow(df3) > 0) { - df4 <- df3 |> - tidyr::pivot_longer( - cols = -intersect(c(factors, errors, std2_id, "n_obs"), colnames(df3)), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate(module_name = parm_sel) - } else { - df4 <- df3 - } - if ("seas" %in% colnames(df4)) { - df4 <- df4 |> - dplyr::rename(season = seas) - } - df4 <- dplyr::mutate(df4, module_name = parm_sel) - df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA - if (ncol(out_new) < ncol(df4)) { - diff <- setdiff(names(df4), names(out_new)) - cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) - # warning(parm_sel, " has more columns than the output data frame. The column(s) ", paste(diff, collapse = ", ")," are not found in the standard file. It was excluded from the resulting output. Please open an issue for developer fix.") - df4 <- dplyr::select(df4, -tidyselect::all_of(diff)) - } - comps_list[[i]] <- df4 - } - # 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 - area_row <- which(apply(extract, 1, function(row) any(row == "Area:"))) - area_val <- c(t(extract[area_row, 3:ncol(extract)])) - gp_row <- which(apply(extract, 1, function(row) any(row == "GP:"))) - gp_val <- c(t(extract[gp_row, 3:ncol(extract)])) - df1 <- extract[-c(1:4), ] - col_name_repl <- paste(parm_sel, "_", area_val, "_", gp_val, sep = "") - colnames(df1) <- c("year", "era", col_name_repl) - df2 <- df1 |> - tidyr::pivot_longer( - cols = -intersect(colnames(df1), c(factors, errors)), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate( - area = stringr::str_extract(label, "(?<=_)[0-9]+"), - growth_pattern = stringr::str_extract(label, "(?<=_)[0-9]+$"), - label = stringr::str_extract(label, "^.*?(?=_[0-9]+)"), - module_name = parm_sel - ) - df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - if (ncol(out_new) < ncol(df2)) { - diff <- setdiff(names(df2), names(out_new)) - cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) - df2 <- dplyr::select(df2, -tidyselect::all_of(diff)) - out_list[[parm_sel]] <- df2 - } else { - out_list[[parm_sel]] <- df2 - } - ##### rand #### - } else if (parm_sel %in% rand) { - # KEYWORDS in RAND - # "Input_Variance_Adjustment" - # "SPR_SERIES" - # "selparm(Size)_By_Year_after_adjustments" - # "selparm(Age)_By_Year_after_adjustments" - # "BIOLOGY" - # "SPR/YPR_Profile" - # "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 - # set labels to "fitted_line_x" - # remove first row - naming - # df1 <- extract[-1, ] - # # Find first row without NAs = headers - # df2 <- df1[stats::complete.cases(df1), ] - # # identify first row - # 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 - # df3 <- df1[-c(1:rownum), ] - # colnames(df3) <- tolower(row) - # # add year and manipulate df - # # Extract first year of recruitment - # fyr_row <- which(apply(dat, 1, function(row) any(row == "Start_year:"))) - # first_year <- dat[fyr_row,2] - # # Extract last year - # endyr_row <- which(apply(dat, 1, function(row) any(row == "End_year:"))) - # end_year <- dat[endyr_row,2] - # df4 <- df3 |> - # dplyr::mutate( - # year = seq(first_year, end_year, by = 1), - # ) - # skipping for now cuz not needed - miss_parms <- c(miss_parms, parm_sel) - next - } else if (parm_sel %in% c("sprseries", "SPR_SERIES")) { - if (is.character(file)) { - # split into the 3 dfs then stack - make sure all factors are present - # remove first row - naming - df1 <- extract[-1, ] - # Find first row without NAs = headers - df2 <- df1[stats::complete.cases(df1), ] - # identify first row - 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 - df3 <- df1[-(1:rownum), ] - colnames(df3) <- tolower(row) - } else { - df3 <- extract - colnames(df3) <- tolower(colnames(df3)) - } - # check if there are estimate and acual values within the df - if (any(grepl("actual", colnames(df3)) | grepl("more_f", colnames(df3)))) { - actual_col <- grep("actual", colnames(df3)) - moref_col <- grep("more_f", colnames(df3)) - # Separate out parts of the dataframe - sub_df1 <- df3[, 1:(actual_col - 1)] |> - tidyr::pivot_longer( - cols = -c(yr, era), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::rename(year = yr) |> - dplyr::mutate( - label = dplyr::case_when( - label == "bio_all" ~ "biomass", - label == "bio_smry" ~ "biomass_midyear", - label == "ssbzero" ~ "spawning_biomass_zero", - # label == "ssbfished" ~ "spawning_biomass", - label == "ssbfished/r" ~ "ssbfished_r", - TRUE ~ label - ), - # 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), - names_to = "label", - values_to = "initial" - ) |> - dplyr::rename(year = yr) |> - dplyr::mutate( - label = dplyr::case_when( - label == "bio_all" ~ "biomass", - label == "bio_smry" ~ "biomass_midyear", - label == "num_smry" ~ "abundance_midyear", - label == "dead_catch" ~ "total_catch", # dead + retained - label == "retain_catch" ~ "landings", - label == "ssb" ~ "spawning_biomass", - label == "recruits" ~ "recruitment", - TRUE ~ label - ), - # change so that the values are placed in the column "initial" then combine w/ estimates - # label = paste("actual_", label, sep = ""), - morph = NA - ) - # combine above 2 since they show the estimate and actual values - matching - sub_df12 <- dplyr::full_join( - sub_df1, - sub_df2, - by = c("year", "era", "label", "morph") - ) - # extract last part of df - sub_df3 <- df3[, c(1:2, (moref_col + 1):ncol(df3))] |> - tidyr::pivot_longer( - cols = -c(yr, era), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::rename(year = yr) |> - dplyr::mutate( - morph = dplyr::case_when( - grepl("avef_|maxf_", label) ~ stringr::str_extract(label, "[0-9]+$"), - TRUE ~ NA_character_ - ), - label = dplyr::case_when( - grepl("avef_", label) ~ stringr::str_remove(label, "_[0-9]+"), - grepl("maxf_", label) ~ stringr::str_remove(label, "_[0-9]+"), - label == "f=z-m" ~ "fishing_mortality", - TRUE ~ label - ), - initial = NA - ) - # combine all subdataframes - df4 <- rbind(sub_df12, sub_df3) |> - dplyr::mutate(module_name = parm_sel) - } else { - df4 <- df3 |> - tidyr::pivot_longer( - cols = -c(intersect(colnames(df3), c("Yr", "yr", "era"))), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::rename(year = intersect(colnames(df3), c("Yr", "yr", "Year"))) |> - dplyr::mutate( - label = dplyr::case_when( - grepl("bio_all", label) ~ "biomass", - grepl("bio_smry", label) ~ "biomass_midyear", - label == "ssbzero" ~ "spawning_biomass_zero", - # label == "ssbfished" ~ "spawning_biomass", - grepl("SSB_unfished", label) ~ "SSB_unfished", - grepl("SSBfished_eq", label) ~ "SSB_fished", - label == "ssbfished/r" ~ "ssbfished_r", - TRUE ~ label - ), - # label = paste("estimate_", label, sep = ""), - morph = NA, - module_name = parm_sel - ) - } - # match to out_new - df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA - # Add to out list - out_list[[parm_sel]] <- df4 - } else if (parm_sel == "selparm(Size)_By_Year_after_adjustments") { - # TODO: revisit one day in group work - # skipping this one because there are no headers - miss_parms <- c(miss_parms, parm_sel) - next - } else if (parm_sel == "selparm(Age)_By_Year_after_adjustments") { - # also skipping - miss_parms <- c(miss_parms, parm_sel) - next - } else if (parm_sel == "BIOLOGY") { - # not sure how this output is helpful - miss_parms <- c(miss_parms, parm_sel) - next - } else if (parm_sel == "SPR/YPR_Profile") { - miss_parms <- c(miss_parms, parm_sel) - next - } else if (parm_sel == "Biology_at_age_in_endyr") { - miss_parms <- c(miss_parms, parm_sel) - next - } else if (tolower(parm_sel) == "parameters") { - if (is.character(file)) { - df1 <- extract[-1, ] - # Find first row without NAs = headers - # temp fix for catch df - df2 <- df1[stats::complete.cases(df1), ] - if (any(c("#") %in% df2[, 1])) { - full_row <- which(apply(df1, 1, function(row) is.na(row) | row == " " | row == "-" | row == "#"))[1] - df1 <- df1[-full_row[1], ] - df1 <- Filter(function(x) !all(is.na(x)), df1) - df2 <- df1[stats::complete.cases(df1), ] - } - # identify first row - 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 - df3 <- df1[-c(1:rownum), ] - colnames(df3) <- tolower(row) - } else { - df3 <- extract - colnames(df3) <- tolower(colnames(df3)) - } - # Pull out indexing variables and remove from labels - df4 <- df3 |> - dplyr::select(intersect(colnames(df3), c("label", "value", "init", "parm_stdev"))) |> - dplyr::rename( - estimate = value, - initial = init, - uncertainty = parm_stdev - ) |> - dplyr::mutate( - uncertainty = dplyr::case_when( - uncertainty == "_" ~ NA, - TRUE ~ uncertainty - ), - uncertainty_label = dplyr::case_when( - is.na(uncertainty) ~ NA, - TRUE ~ "sd" - ), - area = dplyr::case_when( - grepl("?_area_[0-9]_?", label) ~ stringr::str_extract(label, "(?<=area_)[0-9]+"), - grepl("_[0-9]_", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), - grepl(":_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]+"), - grepl(":_[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9][0-9]+"), - TRUE ~ NA - ), - sex = dplyr::case_when( - grepl("_fem_", label) ~ "female", - grepl("_mal_", label) ~ "male", - grepl("_sx:1$", label) ~ "female", - grepl("_sx:2$", label) ~ "male", - grepl("_sx:1_", label) ~ "female", - grepl("_sx:2_", label) ~ "male", - grepl("Male", label) ~ "male", - grepl("Female", label) ~ "female", - TRUE ~ NA - ), - growth_pattern = dplyr::case_when( - grepl("_gp_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]$"), - grepl("_gp:[0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9]$"), - grepl("_gp:[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9][0-9]$"), - grepl("_GP_[0-9]$", label) ~ stringr::str_extract(label, "(?<=_)[0-9]$"), - grepl("_GP:[0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9]$"), - grepl("_GP:[0-9][0-9]$", label) ~ stringr::str_extract(label, "(?<=:)[0-9][0-9]$"), - TRUE ~ NA - ), - month = dplyr::case_when( - grepl("_month_[0-9]+$", label) ~ stringr::str_extract(label, "(?<=month_)[0-9]+$"), - TRUE ~ ifelse(any(grepl("^month$", colnames(df3))), month, NA) - ), - age = dplyr::case_when( - grepl("InitAge", label) ~ stringr::str_extract(label, "(?<=InitAge_)[0-9]+"), - TRUE ~ NA - ), - year = dplyr::case_when( - grepl("RecrDev", label) ~ stringr::str_extract(label, "(?<=RecrDev_)[0-9]+$"), - grepl("_[0-9]{4}$", label) ~ stringr::str_extract(label, "[0-9]{4}$"), - TRUE ~ NA - ), - era = dplyr::case_when( - grepl("InitAge", label) ~ stringr::str_extract(label, "^.*?(?=_InitAge_[0-9]+$)"), - grepl("RecrDev", label) ~ stringr::str_extract(label, "^.*?(?=_RecrDev)"), - TRUE ~ NA - ), - fleet = dplyr::case_when( - grepl( - paste( - fleet_names, - collapse = "|" - ), - label - ) ~ stringr::str_extract(label, paste0("(^.*?_)?<=|", paste(fleet_names, collapse = "|"))), - TRUE ~ NA - ), - block = dplyr::case_when( - grepl("_BLK[0-9]repl_[0-9]{4}$", label) ~ stringr::str_extract(label, "(?<=_BLK)[0-9](?=repl_[0-9]{4}$)"), - TRUE ~ NA - ), - # Must be last step in mutate bc all info comes from the - label = dplyr::case_when( - grepl("?_month_[0-9]_?", label) ~ stringr::str_replace(label, "_?month_\\d?", ""), - grepl("?_area_[0-9]_?", label) ~ stringr::str_replace(label, "_?area_\\d?", ""), - grepl("InitAge", label) ~ "initial_age", - grepl("RecrDev", label) ~ "recruitment_deviations", - grepl( - paste0( - paste0( - "_", - fleet_names, - collapse = "|" - ), - "\\([0-9]+\\)_BLK[0-9]repl_[0-9]{4}$" - ), - label - ) ~ stringr::str_remove_all(label, "(Male_|Female_)|(_[[:alnum:]]+\\([0-9]+\\))|(_BLK[0-9]repl_[0-9]{4})"), - grepl("Male_|Female_", label) & grepl(paste0(paste0("_", fleet_names, collapse = "|"), "\\([0-9]+\\)"), label) ~ stringr::str_remove_all(label, "(Male_|Female_)|(_[[:alnum:]]+\\([0-9]+\\))"), - grepl(paste0(paste0("_", fleet_names, collapse = "|"), "\\([0-9]+\\)"), label) ~ stringr::str_remove(label, paste0(paste0("_", fleet_names, "\\([0-9]+\\)", collapse = "|"))), # , paste0("_", fleet_names, collapse = "|") - TRUE ~ stringr::str_extract(label, "^.*?(?=_\\d|_gp|_fem|_mal|_sx|:|$)") - ), - # fix remaining labels - label = ifelse(grepl("_GP$", label), stringr::str_remove(label, "_GP$"), label), - label = ifelse(grepl("_Fem|_Mal", label), stringr::str_remove(label, "_Fem$|_Mal$"), label), - label = ifelse(grepl(paste0(fleet_names, collapse = "|"), label), stringr::str_remove(label, paste0("_", fleet_names, collapse = "|")), label), - module_name = parm_sel - ) - # match to out_new - df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA - # Add to out list - out_list[[parm_sel]] <- df4 - } else { - miss_parms <- c(miss_parms, parm_sel) - next - } - # miss_parms <- c(miss_parms, parm_sel) - # next - #### info #### - } else if (parm_sel %in% info) { - # if (parm_sel == "LIKELIHOOD") { - # df1 <- extract[-1, ] - # # make row the header names for first df - # colnames(df1) <- df1[1, ] - # # Remove first row containing column names - # df2 <- df1[-1, ] |> - # dplyr::rename(label = Component) |> - # tidyr::pivot_longer( - # cols = -label, - # names_to = "type", - # values_to = "likelihood" - # ) - # # match to out_new - # df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - # # Add to out list - # out_list[[parm_sel]] <- df2 - # } else - if (parm_sel == "DEFINITIONS") { - # Extract start year and end year for iding era - start_year <- as.numeric(extract[which(apply(extract, 1, function(row) any(row == "Start_year:"))), 2]) - end_year <- as.numeric(extract[which(apply(extract, 1, function(row) any(row == "End_year:"))), 2]) - # Pull out only the first two columns and remove first row keyword - # df1 <- extract[-1, 1:2] - # colnames(df1) <- c("label", "estimate") - # # find where rescale is located - # col_rescale <- grep("rescaled_to_sum_to:", extract) - # rescaled_months <- extract[4, col_rescale + 1] |> dplyr::pull() - # # remove : from all labels and tolower and add in rescaled months - # df2 <- df1 |> - # rbind(data.frame( - # label = "rescaled_months", - # estimate = rescaled_months - # )) |> - # dplyr::mutate( - # label = tolower(stringr::str_remove_all(label, ":")), - # module_name = parm_sel - # ) - # # match to out_new - # df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - # # Add to out list - # out_list[[parm_sel]] <- df2 - } else { - miss_parms <- c(miss_parms, parm_sel) - next - } - #### aa.al #### - } else if (parm_sel %in% aa.al) { - # 8,9,11,12,13,14,15,16,28,29 - if (is.character(file)) { - # remove first row - naming - df1 <- extract[-1, ] - # Find first row without NAs = headers - df2 <- df1[stats::complete.cases(df1), ] - # identify first row - row <- df2[1, ] - if (any(row %in% "XX")) { - loc_xx <- grep("XX", row) - 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 <- 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 <- row_match(row, df1) - # Subset data frame - df3 <- df1[-c(1:rownum), ] - colnames(df3) <- tolower(row) - } else { - # Remove XX columns left in dataframe - if (any("xx" %in% tolower(colnames(extract)))) { - # ID which cols contain XX - df3 <- extract[, -grep("xx", tolower(colnames(extract)))] - } else { - df3 <- extract - } - colnames(df3) <- tolower(colnames(df3)) - } - # aa.al names - naming <- c( - "biomass", "discard", "catch", - "f", "mean_size", "numbers", "Lsel", "sel", - "mean_body_wt", "natural_mortality" - ) - if (stringr::str_detect(tolower(parm_sel), paste(naming, collapse = "|"))) { - label <- stringr::str_extract(tolower(parm_sel), paste(naming, collapse = "|")) - if (length(label) > 1) cli::cli_alert_warning("Length of label is > 1.") - 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" - ) - ) - } - if (grepl("age", tolower(parm_sel))) { - fac <- "age" - } else if (any(grepl("length|len", tolower(parm_sel)))) { - fac <- "len_bins" - } else if (any(grepl("size", tolower(parm_sel)))) { - fac <- "len_bins" - } 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 |> - dplyr::rename(year = yr) - } - if (any(colnames(df3) %in% c("seas"))) { - df3 <- df3 |> - dplyr::rename(season = seas) - } - if (any(colnames(df3) %in% c("subseas"))) { - df3 <- df3 |> - dplyr::rename(subseason = subseas) - } - # if ("label" %in% colnames(df3)) { - # df3 <- dplyr::select(df3, -tidyselect::any_of("label")) - # } - # If factor exists, set to label - if ("factor" %in% colnames(df3)) { - df3 <- df3 |> - dplyr::select(-tidyselect::any_of("label")) |> - dplyr::rename(label = factor) - } else if ("type" %in% colnames(df3)) { - df3 <- df3 |> - dplyr::mutate(label = glue::glue("{label}_{type}")) |> - dplyr::select(-type) - } else { - df3 <- dplyr::mutate(df3, label = label[1]) - } - # Change all columns to chatacters to a avoid issues in pivoting - this will be changed in final df anyway - df3 <- df3 |> - dplyr::mutate(dplyr::across(tidyselect::everything(), as.character)) - # Set all columns after factors as numeric - # Identify last factor col - other_factors <- c( - "bio_pattern", "birthseas", - "settlement", "morph", "beg/mid", - "type", "label", "label", - "platoon", "month", - "sexes", "part", "bin", "kind" - ) - num_cols <- setdiff(colnames(df3), c(factors, other_factors)) - df3 <- df3 |> - dplyr::mutate(dplyr::across(dplyr::all_of(num_cols), as.numeric)) - # Pivot table long - df4 <- df3 |> - tidyr::pivot_longer( - cols = -intersect(c(factors, errors, other_factors), colnames(df3)), - names_to = fac[1], - values_to = "estimate" - ) |> - dplyr::mutate( - # label = label[1], - module_name = parm_sel[1] - ) - if ("sex" %in% colnames(df4)) { - df4 <- df4 |> - dplyr::mutate( - sex = dplyr::case_when( - "sex" %in% colnames(df3) & sex == 1 ~ "female", - "sex" %in% colnames(df3) & sex == 2 ~ "male" - ) - ) - } - if (any(grepl("morph", colnames(df4)))) { - df4 <- df4 |> - dplyr::rename(growth_pattern = morph) - } - # Check if likelihood is in the df - if (any(grepl("like", colnames(df4)))) { - df4 <- df4 |> - dplyr::rename(likelihood = like) - } - # Rename beg/mid if present - if (any(grepl("beg/mid", colnames(df4)))) { - df4 <- df4 |> - dplyr::rename(beg_mid = "beg/mid") - } - # Check for error in the df - if (any(grepl(paste0("^", errors, "$", collapse = "|"), colnames(df4)))) { - error_col <- colnames(df4)[grep(paste0("^", errors, "$", collapse = "|"), colnames(df4))] - if (length(error_col) > 1) { - cli::cli_alert("Multiple error columns present. Error will not be added to module.") - } else { - df4 <- df4 |> - dplyr::mutate( - uncertainty_label = tolower(unique(error_col)), - uncertainty = df4[[error_col]] - ) - } - } - if ("label" %in% colnames(df4) & "factor" %in% colnames(df4)) { - df4 <- df4 |> - dplyr::select(-label) |> - dplyr::mutate(label = dplyr::case_when( - grepl("sel", factor) ~ "sel", - TRUE ~ factor - )) |> - dplyr::select(-factor) - } - # Bind to new df - df4[setdiff(tolower(names(out_new)), tolower(names(df4)))] <- NA - if (ncol(out_new) < ncol(df4)) { - diff <- setdiff(names(df4), names(out_new)) - cli::cli_alert_info(paste0("FACTORS REMOVED: ", parm_sel, " - ", paste(diff, collapse = ", "))) - # warning(parm_sel, " has more columns than the output data frame. The column(s) ", paste(diff, collapse = ", ")," are not found in the standard file. It was excluded from the resulting output. Please open an issue for developer fix.") - df4 <- dplyr::select(df4, -tidyselect::all_of(diff)) - out_list[[parm_sel]] <- df4 - } else { - out_list[[parm_sel]] <- df4 - } - # } else if (parm_sel %in% nn) { - # miss_parms <- c(miss_parms, parm_sel) - # next - } else { - cli::cli_alert_info(glue::glue("Processing {parm_sel}")) - miss_parms <- c(miss_parms, parm_sel) - next - } - } # close if param is in output file - #### skip parm in ss3 #### - } else { - if (is.character(file)) cli::cli_alert(glue::glue("Skipped [{i}] {parm_sel}")) - next - } - } # close loop - if (length(miss_parms) > 0) { - cli::cli_alert_info( - paste0("Some parameters were not found or included in the output file. The following parameters were not added into the new output file: \n", paste(miss_parms, collapse = "\n")) - ) - } - out_new <- Reduce(rbind, out_list) - out_new <- out_new |> - dplyr::mutate( - fleet = if (any(unique(out_new$fleet) %in% fleet_names)) fleet else fleet_names[fleet], - era = dplyr::case_when( - !is.na(era) ~ era, - year < start_year ~ "init", - year >= start_year & year <= end_year ~ "time", - year > end_year ~ "fore", - TRUE ~ NA_character_ - ) - ) + out_new <- conout_ss3(file = file, out_new = out_new, fleet_names = fleet_names) } else if (model %in% c("bam", "BAM")) { #### BAM #### - # Extract values from BAM output - model file after following ADMB2R - dat <- dget(file) - - # Find fleet names - if (is.null(fleet_names)) { - # Extract names from indices - indices <- dat$t.series |> - dplyr::select(dplyr::contains("U.") & dplyr::contains(".ob")) - fleets_ind <- stringr::str_extract(as.vector(colnames(indices)), "(?<=U\\.)\\w+(?=\\.ob)") - # Extract names from landings - landings <- dat$t.series |> - dplyr::select(dplyr::contains("L.") & dplyr::contains(".ob") | - dplyr::contains("D.") & dplyr::contains(".ob")) - fleets_land <- stringr::str_extract(as.vector(colnames(landings)), "(?<=L\\.)\\w+(?=\\.ob)") - fleets_disc <- stringr::str_extract(as.vector(colnames(landings)), "(?<=D\\.)\\w+(?=\\.ob)") - # Extract names from lof F dev - parm <- dat$parm.tvec |> - dplyr::select(dplyr::contains("log.F.dev.") | - dplyr::contains("log.F.dev.") & dplyr::contains(".D")) - # fleets_parm_D <- stringr::str_extract(as.vector(colnames(parm)), "(?<=log\\.F\\.dev\\.)\\w+(?=\\.D)") - fleets_parm <- stringr::str_extract(as.vector(colnames(parm)), "(?<=log\\.F\\.dev\\.)\\w+") - fleets <- unique(tolower(c(fleets_ind, fleets_land, fleets_disc, fleets_parm))) - fleet_names <- fleets[!is.na(fleets)] - if (any(is.na(fleet_names))) { - cli::cli_abort("No fleet names found in dataframe. Please indicate the abbreviations of fleet names using fleet_names arg.") - } - } # else { - # # check fleet names are input - # # if (any(is.na(fleet_names))) { - # fleet_names <- fleet_names - # } - # 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") - # argument for function when model == BAM - # fleet_names <- c("cl", "cL","cp","mrip","ct", "hb", "HB", "comm","Mbft","CVID") - - ##### BAM loop ---- - # Extract data from list fit to output df - # Loop over all items to output each object/transform - # Not transforming or including info chunk - for (p in 2:length(dat)) { - extract <- dat[p] - cli::cli_alert_info(glue::glue("Processing {names(extract)}")) - # is the object class matrix, list, or vector - if (is.vector(extract[[1]])) { - if (is.list(extract[[1]])) { # indicates vector and list - if (any(vapply(extract[[1]], is.matrix, FUN.VALUE = logical(1)))) { - extract_list <- list() - for (i in seq_along(extract[[1]])) { - if (is.vector(extract[[1]][[i]])) { - df <- as.data.frame(extract[[1]][i]) |> - tibble::rownames_to_column(var = "age") |> - tidyr::pivot_longer( - cols = -age, - values_to = "estimate", - names_to = "label" - ) |> - dplyr::mutate( - label = names(extract[[1]][i]), - # label_init = names(extract[[1]][i]), - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), - TRUE ~ NA - ), - module_name = names(extract), - label = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), ""), - TRUE ~ label - ) - ) - df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA - extract_list[[names(extract[[1]][i])]] <- df - } else { - df <- as.data.frame(extract[[1]][[i]]) |> - tibble::rownames_to_column(var = "year") - df <- df |> - dplyr::rename_with( - ~ ifelse(max(as.numeric(df$year)) < 50, - c("age_a"), c("year") - ), - year - ) - if (grepl("lcomp", names(extract[[1]][i]))) { - namesto <- "len_bins" - } else if (grepl("acomp", names(extract[[1]][i]))) { - namesto <- "age" - } else { - # Default - namesto <- "age" - } - df2 <- df |> - tidyr::pivot_longer( - cols = -intersect(colnames(df), c("year", "age_a")), - names_to = namesto, - values_to = "estimate" - ) |> - dplyr::mutate( - module_name = names(extract), - label = names(extract[[1]][i]), - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), tolower(label)) ~ stringr::str_extract(tolower(label), paste(fleet_names, collapse = "|")), - TRUE ~ NA - ), # stringr::str_extract(module_name, "(?<=\\.)\\w+(?=\\.)"), - label = dplyr::case_when( - grepl(paste0(fleet_names, collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste0(".", fleet_names, collapse = "|"), ""), - TRUE ~ names(extract[[1]][i]) - ) - # label_init = names(extract[[1]][i]), - - # label = dplyr::case_when( - # is.na(fleet) ~ names(extract[[1]][i]), - # TRUE ~ stringr::str_replace(tolower(label), paste(".", fleet_names, sep = "", collapse = "|"), "") - # ) - ) # stringr::str_replace(module_name, "\\.[^.]+\\.", ".")) - df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - extract_list[[names(extract[[1]][i])]] <- df2 - } # close if statement - } # close for loop - new_df <- Reduce(rbind, extract_list) - out_list[[names(extract)]] <- new_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 - df <- data.frame(extract[[1]]) - if (length(intersect(colnames(df), c(factors, errors))) > 0) { - df2 <- df |> - tidyr::pivot_longer( - cols = -intersect(colnames(df), c(factors, errors)), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate(module_name = names(extract)) - } else { - df2 <- df |> - tidyr::pivot_longer( - cols = tidyselect::everything(), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate(module_name = names(extract)) - } - if (any(grepl(paste(fleet_names, collapse = "|"), unique(df2$label)))) { - df2 <- df2 |> - dplyr::mutate( - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), tolower(label)) ~ stringr::str_extract(tolower(label), paste(fleet_names, collapse = "|")), - # grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(ex, paste(fleet_names,collapse="|")), - TRUE ~ NA - ), - # Number after fleet name is what? variable among df? - age = dplyr::case_when( - grepl("r0$|b0$", tolower(label)) ~ NA, - module_name != "parms" & grepl(".Age[0-9]+.", label) ~ stringr::str_extract(label, "(?<=.Age?)[0-9]+"), - module_name != "parms" & grepl("[0-9]+$", label) & as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_extract(label, "[0-9]+$"), - module_name != "parms" & grepl("_age[0-9]+.", label) ~ stringr::str_extract(label, "(?<=_age?)[0-9]+"), - TRUE ~ NA - ), - label = dplyr::case_when( - # below will only work properly if there are age varying parameters without fleet names in it - module_name == "parms" & !grepl(paste(".", fleet_names, sep = "", collapse = "|"), tolower(label)) ~ label, - module_name == "parm.cons" & !grepl(paste("_", fleet_names, sep = "", collapse = "|"), tolower(label)) ~ label, - grepl(paste(".", fleet_names, "d[0-9]+", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(".", fleet_names, "d[0-9]+", sep = "", collapse = "|"), ".d"), - grepl(paste(".", fleet_names, "[0-9]+$", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(fleet_names, sep = "", collapse = "|"), ""), # "[0-9]+", - grepl(paste(".", fleet_names, "$", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(".", fleet_names, sep = "", collapse = "|"), ""), - grepl(paste("_", fleet_names, "_", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste("_", fleet_names, sep = "", collapse = "|"), ""), - grepl(paste(".", fleet_names, ".d$", sep = "", collapse = "|"), tolower(label)) ~ stringr::str_replace(tolower(label), paste(".", fleet_names, sep = "", collapse = "|"), ""), - grepl(".Age[0-9]+.[a-z]+", label) ~ stringr::str_replace(label, ".Age[0-9]+.[a-z]+", ""), - grepl("[0-9]+$", label) ~ stringr::str_replace(label, "[0-9]+$", ""), - # !is.na(fleet) | !is.na(age) ~ stringr::str_replace(label, paste(c(paste(".", fleet_names, "[0-9]+", sep = ""), ".Age[0-9]+.[a-z]+", "[0-9]+$"), collapse = "|"), ""), - # as.numeric(stringr::str_extract(label, "[0-9]+$")) == 0 ~ label, - # as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_remove(label, "[0-9]+$"), - TRUE ~ label - ), - # additional manipulation of label to remove age in parm.cons - label = dplyr::case_when( - module_name == "parm.cons" & grepl("_age[0-9]+.[a-z]+", label) ~ stringr::str_replace(label, "_age[0-9]+.[a-z]+", ""), - TRUE ~ label - ) - ) - } else if (any(grepl("[0-9]$", unique(df2$label)))) { - df2 <- df2 |> - dplyr::mutate( - fleet = NA, - # Number after fleet name is what? variable among df? - age = dplyr::case_when( - grepl("[0-9]+$", label) & stringr::str_extract(label, "[0-9]+$") < 30 ~ stringr::str_extract(label, "[0-9]+$"), - TRUE ~ NA - ), - # label_init = label, - label = dplyr::case_when( - as.numeric(stringr::str_extract(label, "[0-9]+$")) == 0 ~ label, - as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_remove(label, "[0-9]+$"), - TRUE ~ label - ) - ) - } else { - df2 <- df2 |> - dplyr::mutate( - fleet = ifelse("age" %in% colnames(df2), fleet, NA), - age = ifelse("age" %in% colnames(df2), age, NA), - label = label, - module_name = names(extract) - ) - } - df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - out_list[[names(extract)]] <- df2 - } else { - cli::cli_alert_warning("Not compatible.") - } - } else { # vector only - df <- as.data.frame(extract) |> - tibble::rownames_to_column(var = "label") |> - tidyr::pivot_longer( - cols = -label, - names_to = "module_name", - values_to = "estimate" - ) - if (any(grepl("age", colnames(df)))) { - df <- df |> - tidyr::pivot_longer( - cols = -intersect(c(factors, errors), colnames(df)), - names_to = "age", - values_to = "estimate" - ) |> - dplyr::mutate( - label = names(extract[[1]]), - age = dplyr::case_when( - grepl(".[0-9]$", age) ~ stringr::str_extract(age, "[0-9]"), - grepl(".[0-9][0-9]$", age) ~ stringr::str_extract(age, "[0-9][0-9]"), - TRUE ~ NA - ), - module_name = names(extract) - ) - } - if (any(grepl(paste(fleet_names, collapse = "|"), df$label))) { - df <- df |> - dplyr::mutate( - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), - TRUE ~ NA - ), - label = dplyr::case_when( - is.na(fleet) ~ label, - TRUE ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), "") - ) - ) - } - df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA - out_list[[names(extract)]] <- df - } - } else if (is.list(extract[[1]])) { # list only - if (any(vapply(extract[[1]], is.matrix, FUN.VALUE = logical(1)))) { - extract_list <- list() - for (i in seq_along(extract[[1]])) { - if (is.vector(extract[[1]][[i]])) { - df <- as.data.frame(extract[[1]][i]) |> - tibble::rownames_to_column(var = "age") |> - tidyr::pivot_longer( - cols = -age, - values_to = "estimate", - names_to = "label" - ) |> - dplyr::mutate( - label = names(extract[[1]][i]), - # label_init = names(extract[[1]][i]), - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), - TRUE ~ NA - ), - module_name = names(extract), - label = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), ""), - TRUE ~ label - ) - ) - df[setdiff(tolower(names(out_new)), tolower(names(df)))] <- NA - extract_list[[names(extract[[1]][i])]] <- df - } else { - df <- as.data.frame(extract[[1]][[i]]) |> - tibble::rownames_to_column(var = "year") - if (grepl("lcomp", names(extract[[1]][i]))) { - namesto <- "len_bins" - } else if (grepl("acomp", names(extract[[1]][i]))) { - namesto <- "age" - } else { - # Default - namesto <- "age" - } - df2 <- df |> - tidyr::pivot_longer( - cols = -year, - names_to = namesto, - values_to = "estimate" - ) |> - dplyr::mutate( - module_name = names(extract), - label = names(extract[[1]][i]), - # label_init = names(extract[[1]][i]), - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), - TRUE ~ NA - ), # stringr::str_extract(module_name, "(?<=\\.)\\w+(?=\\.)"), - label = dplyr::case_when( - is.na(fleet) ~ names(extract[[1]][i]), - TRUE ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), "") - ) - ) # stringr::str_replace(module_name, "\\.[^.]+\\.", ".")) - df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - extract_list[[names(extract[[1]][i])]] <- df2 - } # close if statement - } # close for loop - new_df <- Reduce(rbind, extract_list) - out_list[[names(extract)]] <- new_df - } else if (any(sapply(extract[[1]], is.vector))) { # all must be a vector to work - so there must be conditions for dfs with a mix - df <- data.frame(extract[[1]]) - if (max(as.numeric(row.names(df))) < 1000) { - fac <- "age" - } else if (1000 < max(as.numeric(row.names(df))) & max(as.numeric(row.names(df))) < 2100) { - fac <- "year" - } else { - fac <- "nsim" - } - if (any(colnames(df) %in% c("age", "year"))) { - df <- df - } else { - if (fac == "year") { - df <- tibble::rowid_to_column(df, var = fac) |> - dplyr::mutate(year = as.character(year)) - } else if (fac == "age") { - df <- tibble::rowid_to_column(df, var = fac) |> - dplyr::mutate(age = as.character(age)) - } else if (fac == "nsim") { - df <- tibble::rowid_to_column(df, var = fac) |> - dplyr::mutate(nsim = as.character(nsim)) - } else { - cli::cli_alert_warning("Not compatible") - } - } - # # Check if any col names contain error then select - # if (any(grepl(paste0(errors, collapse = "|"), colnames(df)))) { - # error_cols <- grep(paste0(errors, ".", collapse = "|"), colnames(df)) - # } else { - # error_cols <- NULL - # } - if (length(intersect(colnames(df), c(factors, errors))) > 0) { - df2 <- df |> - tidyr::pivot_longer( - cols = -intersect(colnames(df), c(factors, errors)), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate(module_name = names(extract)) - } else { - df2 <- df |> - tidyr::pivot_longer( - cols = tidyselect::everything(), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate(module_name = names(extract)) - } - if (any(grepl(paste(fleet_names, collapse = "|"), tolower(unique(df2$label))))) { - if ("age" %in% colnames(df2)) { - df2 <- df2 - } else { - df2 <- df2 |> - dplyr::mutate(age = NA) - } - df2 <- df2 |> - dplyr::mutate( - label = tolower(label), - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), - # grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(ex, paste(fleet_names,collapse="|")), - TRUE ~ NA - ), - # Number after fleet name is what? variable among df? - age = dplyr::case_when( - is.na(as.numeric(age)) & grepl("_age[0-9]+_", label) ~ as.numeric(stringr::str_extract(label, "(?<=age:?)[0-9]+")), - is.na(as.numeric(age)) & grepl("[0-9]+$", label) ~ as.numeric(stringr::str_extract(label, "[0-9]+$")), # this is not age - TRUE ~ as.numeric(age) - ), - # area = dplyr::case_when(is.na(age) & grepl("[0-9]+$", label) ~ stringr::str_extract(label, "[0-9]+$"), # this is not age - # TRUE ~ NA), - # Uncomment when units gets added in - # units = dplyr::case_when( - # grepl(paste(units, collapse = "|"), label) ~ stringr::str_extract(label, paste(units, collapse = "|")), - # TRUE ~ NA - # ), - label = dplyr::case_when( - # grepl("_age[0-9]_", label) & grepl(paste("_", fleet_names, "[0-9]+", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_age[0-9]+_", fleet_names, "[0-9]+", sep = "", collapse = "|"), ""), - # grepl("_age[0-9]_", label) & grepl(paste("_", fleet_names, sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_age[0-9]+_", fleet_names, sep = "", collapse = "|"), ""), - # grepl("_age[0-9]_", label) ~ stringr::str_replace(label, "_age[0-9]+_", ""), - # grepl(paste0(rep(fleet_names, times = length(units)), ".", units, collapse = "|"), label) ~ stringr::str_replace(label, paste0(".", rep(fleet_names, times = length(units)), ".", units, collapse = "|"), ""), - grepl(paste("_", fleet_names, "[0-9]+$", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_", fleet_names, "[0-9]+$", sep = "", collapse = "|"), ""), - grepl(paste("_", fleet_names, sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste("_", fleet_names, sep = "", collapse = "|"), ""), - grepl(paste(".", fleet_names, "[0-9]+$", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(fleet_names, sep = "", collapse = "|"), ""), - grepl(paste(fleet_names, ".", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(fleet_names, ".", sep = "", collapse = "|"), ""), - grepl(paste(".", fleet_names, "d[0-9]+$", sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, "d[0-9]+$", sep = "", collapse = "|"), ""), - grepl(paste(".", fleet_names, sep = "", collapse = "|"), label) ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), ""), - grepl(paste(fleet_names, "[0-9]+$", collapse = "|"), label) ~ stringr::str_replace(label, "[0-9]+$", ""), - TRUE ~ label - ) - ) - } else if (any(grepl("[0-9]$", unique(df2$label)))) { - df2 <- df2 |> - dplyr::mutate( - fleet = NA, - # Number after fleet name is what? variable among df? - age = dplyr::case_when( - grepl("[0-9]+$", label) & stringr::str_extract(label, "[0-9]+$") < 30 ~ stringr::str_extract(label, "[0-9]+$"), - TRUE ~ NA - ), - # label_init = label, - label = dplyr::case_when( - as.numeric(stringr::str_extract(label, "[0-9]+$")) == 0 ~ label, - # issue here that stocks with ages > 29 will not be extracted - maybe add condition if F, t or other preceeeds the number then don't extract? - as.numeric(stringr::str_extract(label, "[0-9]+$")) < 30 ~ stringr::str_remove(label, "[0-9]+$"), - TRUE ~ label - ) - ) - } else { - df2 <- df2 |> - dplyr::mutate( - fleet = ifelse(any(colnames(df2) %in% c("fleet")), fleet, NA), - age = ifelse(any(colnames(df2) %in% c("age")), fleet, NA), - label = label, - module_name = names(extract) - ) - } - # Move error into column - if (any(grepl(paste0("^", errors, "\\.", collapse = "|"), unique(df2$label)))) { - # Pivot wider only the cv labels and align with their counter part estimate label - error_data <- df2 |> - dplyr::filter(stringr::str_detect(label, paste0("^", errors, ".", collapse = "|"))) |> - dplyr::mutate(match_key = stringr::str_remove(label, paste0("^", errors, ".", collapse = "|"))) |> - dplyr::mutate(uncertainty_label = stringr::str_extract(label, paste0(errors, collapse = "|"))) |> - dplyr::select(year, fleet, match_key, uncertainty = estimate, uncertainty_label) - # filter out error labels - df2_filtered <- df2 |> - dplyr::filter(!stringr::str_detect(label, paste0("^", errors, collapse = "|"))) |> - dplyr::mutate(match_key = stringr::str_extract(label, "^[A-Za-z]+")) - # Join the errors to the final df - df2 <- df2_filtered |> - dplyr::left_join(error_data, by = c("year", "fleet", "match_key")) |> - dplyr::select(-match_key) - } - df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - out_list[[names(extract)]] <- df2 - } else { - cli::cli_alert_warning("Not compatible.") - } - } else if (is.matrix(extract[[1]])) { # matrix only - df <- as.data.frame(extract[[1]]) |> - tibble::rownames_to_column(var = "year") - if (grepl("length", names(extract))) { - namesto <- "len_bins" - } else if (grepl("age", names(extract))) { - namesto <- "age" - } else { - # Default - namesto <- "age" - } - df2 <- df |> - tidyr::pivot_longer( - cols = -year, - names_to = namesto, - values_to = "estimate" - ) |> - dplyr::mutate( - module_name = names(extract), - label = names(extract), - # label_init = names(extract[[1]][i]), - fleet = dplyr::case_when( - grepl(paste(fleet_names, collapse = "|"), label) ~ stringr::str_extract(label, paste(fleet_names, collapse = "|")), - TRUE ~ NA - ), # stringr::str_extract(module_name, "(?<=\\.)\\w+(?=\\.)"), - label = dplyr::case_when( - is.na(fleet) ~ names(extract), - TRUE ~ stringr::str_replace(label, paste(".", fleet_names, sep = "", collapse = "|"), "") - ) - ) # stringr::str_replace(module_name, "\\.[^.]+\\.", ".")) - df2[setdiff(tolower(names(out_new)), tolower(names(df2)))] <- NA - out_list[[names(extract)]] <- df2 - } else { - cli::cli_alert_warning(paste(names(extract), " not compatible.", sep = "")) - } # close if statement - } # close loop over objects listed in dat file - - # Place out_list into a single data frame - # VIRG, INIT, TIME, FORE - 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) - ) - if (model == "bam") { - out_new <- dplyr::mutate( - out_new, - era = dplyr::case_when( - year < dat$parms$styr ~ "init", - year >= dat$parms$styr & year <= dat$parms$endyr ~ "time", - year > dat$parms$endyr ~ "fore", - TRUE ~ NA - ) - ) - } + out_new <- conout_bam(file = file, out_new = out_new, fleet_names = fleet_names) #### WHAM ---- } else if (model == "wham") { @@ -1975,486 +205,7 @@ convert_output <- function( 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)) { - # Anchored and case-insensitive: saveRDS() output is conventionally named - # either .rds or .RDS, and the real assessment files this targets use the - # latter. The unanchored, case-sensitive form rejected them. - if (!grepl("\\.rds$", file, ignore.case = TRUE)) { - cli::cli_abort("File must be in an .rds format otherwise load data into your environment and run `convert_output()` using the loaded data.") - } - dat <- readRDS(file) - } else { - dat <- file - } - - # The standardized output describes one stock and has no species dimension, - # but CEATTLE is a multispecies model. A multispecies fit's `sdrep` holds - # nspp * nyrs values per label, which fails the `n == length(styr:projyr)` - # test used to attach years below, so every biomass / spawning biomass / - # recruitment value would silently come back with `year = NA`. Refuse - # instead: a converted file that quietly merges two stocks is worse than no - # converted file. - # `[[` rather than `$`: `$` partial-matches, so a renamed element would - # return something else and skip the refusal. - if (!"data_list" %in% names(dat)) { - cli::cli_abort(c( - "Rceattle fit has no {.field data_list} element.", - i = "The catch, index and composition data are read from it." - )) - } - nspp <- dat[["data_list"]][["nspp"]] - if (is.null(nspp)) { - cli::cli_abort(c( - "Rceattle fit does not report {.field nspp}, so its species count is unknown.", - i = "The standardized output has no species dimension and must not merge stocks." - )) - } - if (nspp > 1) { - cli::cli_abort(c( - "Rceattle model has {nspp} species, and the standardized output has no species dimension.", - i = "Subset the fit to a single species before converting." - )) - } - - # Extract or use fleet names - if (is.null(fleet_names)) { - fleet_names <- names(dat$estimated_params$index_log_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") - - ##### Loop #### - # Select the modules by name rather than by position. An Rceattle fit's - # element list depends on how it was fitted -- `phase = TRUE` adds - # `.conv_phase` and `phase_params`, and `getsd = FALSE` drops `sdrep` -- so a - # fixed offset selects different modules for different fits of the same - # model. Under `phase = TRUE` the positional form dropped `data_list` and - # passed `obj` to the generic vector handler below, which aborts with - # "attempt to select less than one element in OneIndex". - # - # `sdrep` carries every derived time series, so without it the output holds - # only the input data. Say so rather than returning a table whose biomass - # and recruitment are simply absent. - if (!"sdrep" %in% names(dat)) { - cli::cli_warn(c( - "Rceattle fit has no {.field sdrep}, so the converted output has no biomass, spawning biomass or recruitment.", - i = "Refit with {.code fit_control(getsd = TRUE)} to standardize the derived time series." - )) - } - for (module_name in intersect(c("sdrep", "data_list", "quantities"), names(dat))) { - extract <- dat[module_name] - cli::cli_alert_info("Processing {module_name}") - if (module_name == "sdrep") { - ##### 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( - dat[["data_list"]]$styr:dat[["data_list"]]$projyr, - length(unique( - dplyr::filter(values_count, n == length(dat[["data_list"]]$styr:dat[["data_list"]]$projyr)) |> - dplyr::pull(label) - )) - ) - - df2 <- values |> - dplyr::filter(n == length(dat[["data_list"]]$styr:dat[["data_list"]]$projyr)) |> - dplyr::mutate(year = year_col) - - df2 <- values |> - dplyr::filter( - n != length(dat[["data_list"]]$styr:dat[["data_list"]]$projyr) - ) |> - dplyr::mutate(year = NA) |> - rbind(df2) - - # Extract parameter values ts - # The standard errors of the fixed effects are the square root of the - # diagonal of cov.fixed, in the same order as par.fixed. - has_cov_fixed <- !is.null(extract[[1]]$cov.fixed) - par_fixes <- data.frame( - label = names(extract[[1]]$par.fixed), - estimate = extract[[1]]$par.fixed, - uncertainty = if (has_cov_fixed) sqrt(diag(extract[[1]]$cov.fixed)) else NA_real_, - uncertainty_label = if (has_cov_fixed) "sd" else NA_character_ - ) - # Random effects, such as rec_dev under random_rec = TRUE, are in - # par.random rather than par.fixed. Their variances are in - # diag.cov.random. - if (length(extract[[1]]$par.random) > 0) { - has_cov_random <- !is.null(extract[[1]]$diag.cov.random) - par_fixes <- rbind( - par_fixes, - data.frame( - label = names(extract[[1]]$par.random), - estimate = extract[[1]]$par.random, - uncertainty = if (has_cov_random) sqrt(extract[[1]]$diag.cov.random) else NA_real_, - uncertainty_label = if (has_cov_random) "sd" else NA_character_ - ) - ) - } - 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( - dat[["data_list"]]$styr:dat[["data_list"]]$endyr, - length(unique( - dplyr::filter(par_fixes_count, n == length(dat[["data_list"]]$styr:dat[["data_list"]]$endyr)) |> - dplyr::pull(label) - )) - ) - - df3 <- par_fixes |> - dplyr::filter(n == length(dat[["data_list"]]$styr:dat[["data_list"]]$endyr)) |> - dplyr::mutate(year = year_col_par_fix) - df3 <- par_fixes |> - dplyr::filter( - n != length(dat[["data_list"]]$styr:dat[["data_list"]]$endyr) - ) |> - dplyr::mutate(year = NA) |> - rbind(df3) - # 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 (module_name == "data_list") { - ###### data.list #### - # Only extract specific quantity needs - # comp_data?, index_data, catch_data, weight, Ftarget, Flimit - data_list_list <- list() - - ####### Indices #### - # Extract index_data - df_index <- extract[[1]]$index_data |> - # rename all columns to lower case to match standard - dplyr::rename_with(tolower) |> - dplyr::rename( - fleet = fleet_name, - indices_observed = observation, - block = selectivity_block, - uncertainty = log_sd - ) |> - dplyr::mutate( - # label = "index_observed", - uncertainty_label = "log_sd", - indices_predicted = dat$quantities$index_hat - ) |> - # any_of(): `Q_block` is deprecated in Rceattle and no longer written - # to `index_data`, so naming it directly fails on a current fit while - # still needing to be dropped from an older one. - dplyr::select(-dplyr::any_of(c("fleet_code", "q_block"))) - cli::cli_alert_info("'Selectivity_block' values located in 'block' columns.") - - # check if species > 1 - if (length(unique(df_index$species)) > 1) { - cli::cli_abort("Not currently compatible for multispecies.") - } else { - df_index <- df_index |> - dplyr::select(-species) - } - - # expand df long to have obs and pred in same column with label - df_index_long <- df_index |> - tidyr::pivot_longer( - cols = c(indices_observed, indices_predicted), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::mutate( - module_name = names(extract), - # era = dplyr::if_else( - # year > dat$data_list$endyr, - # "fore", - # NA_character_ - # ) - label = stringr::str_replace_all(label, "indices", "index") - ) - - df_index_long[setdiff(tolower(names(out_new)), tolower(names(df_index_long)))] <- NA - data_list_list[["index_data"]] <- df_index_long - - ####### Catch indexing #### - # Extract catch_data and align with log_index_hat and catch_h - # Modify sdrep in outlist to include index - df_catch <- extract[[1]]$catch_data |> - # dplyr::filter(!is.na(Catch)) |> - dplyr::rename_with(tolower) |> - dplyr::mutate( - module_name = names(extract), - # Set the era here from the year, as the index and composition - # frames do, so the frame is complete where it is built. The mutate - # at the end of the branch recomputes it the same way. - era = dplyr::if_else( - year > dat$data_list$endyr, - "fore", - "time" - ), - catch_h = dat$quantities$catch_hat, - # TODO: follow up on this quantity - # log_index_hat = dat$quantities$log_index_hat - uncertainty_label = "log_sd" - ) |> - dplyr::rename( - catch_predicted = catch_h, - fleet = fleet_name, - block = selectivity_block, - uncertainty = log_sd - ) |> - tidyr::pivot_longer( - cols = c(catch, catch_predicted), - names_to = "label", - values_to = "estimate" - ) |> - dplyr::select(-c(fleet_code, species)) - - # Remove fleet names if do not match object - # if (unique(df_catch$fleet) %notin% fleet_names) { - # df_catch <- df_catch |> - # dplyr::mutate(fleet = NA) - # } - - if (length(unique(df_catch$month)) == 1) { - df_catch$month <- NA - } - df_catch[setdiff(tolower(names(out_new)), tolower(names(df_catch)))] <- NA - data_list_list[["catch_data"]] <- df_catch - - ####### Comp indexing #### - df_comp_obs <- dat$data_list$comp_data |> - dplyr::rename_with(tolower) |> - dplyr::mutate( - label = "index_observed" - ) - - indexing_vars_cols <- colnames(df_comp_obs)[!grepl("comp", colnames(df_comp_obs))] - - # `age_hat` holds one row per row of `comp_data`, in the same order, so - # it binds column-wise. cross_join() paired every observation with the - # whole prediction matrix instead, which is a Cartesian product: on the - # GOAatf fixture it returned the 2,478 correct predictions 59 times - # over, once per row of comp_data, for 146,202 in all. - age_hat <- as.data.frame(dat$quantities$age_hat) - names(age_hat) <- paste0("agehat_", seq_len(ncol(age_hat))) - df_comp_pred <- dplyr::select(df_comp_obs, dplyr::all_of(indexing_vars_cols)) |> - cbind(age_hat) |> - tidyr::pivot_longer( - cols = -dplyr::all_of(indexing_vars_cols), - names_to = "age", - values_to = "estimate" - ) |> - # removes the 0 so assuming there will be no recorded zero catch but Rceattle reports ages up to 117 - dplyr::filter(estimate != 0) |> - dplyr::mutate( - label = "composition_predicted", - # NOTE: the below age mutate slows down code - age = stringr::str_replace(age, "agehat_", "") - ) - - # Finish adjusting comp_obs - # pivot obs data - df_comp_obs <- df_comp_obs |> - tidyr::pivot_longer( - cols = -dplyr::all_of(indexing_vars_cols), - names_to = "age", - values_to = "estimate" - ) |> - dplyr::filter(!is.na(estimate)) |> - dplyr::mutate( - label = "composition_observed", - # NOTE: the below age mutate slows down code - age = stringr::str_replace(age, "comp_", "") - ) - - df_comp <- rbind(df_comp_obs, df_comp_pred) |> - # Match the index and catch frames: the standard names the fleet - # `fleet`, carries no `fleet_name` or `species`, and every row states - # which module it came from. - dplyr::rename(fleet = fleet_name) |> - dplyr::mutate(module_name = names(extract)) |> - dplyr::select(-dplyr::any_of("species")) |> - # TODO: do I need to filter sample size by <3 for confidentiality or does this not apply? - dplyr::select(-c(age0_length1, fleet_code, sample_size)) - - df_comp[setdiff(tolower(names(out_new)), tolower(names(df_comp)))] <- NA - data_list_list[["comp_data"]] <- df_comp - - # final df for data_list module - # rbind() rather than bind_rows(): every frame has already been padded - # to the standard column set above, so rbind() succeeds and keeps the - # column contract -- it aborts on a frame carrying an extra column, - # where bind_rows() would silently widen the output. - new_df <- Reduce(rbind, data_list_list) - out_list[[names(extract)]] <- new_df - } else if (module_name == "quantities") { - ###### quantities #### - # Only selectivity and natural mortality at age for now. Both are - # [fleet or species, sex, age, year] arrays. The age dimension is the - # bin index, so the age itself is offset by minage. - ages <- dat[["data_list"]][["minage"]] - 1 + - seq_len(dat[["data_list"]][["nages"]]) - nsex <- dat[["data_list"]][["nsex"]] - # Rceattle stores sex 1 as females, or both sexes when nsex = 1. - sex_names <- if (nsex == 1) NA_character_ else c("female", "male") - quantities_list <- list() - - if ("sel_at_age" %in% names(extract[[1]])) { - sel <- extract[[1]][["sel_at_age"]][, seq_len(nsex), seq_along(ages), , drop = FALSE] - df_sel <- expand.grid( - fleet = dimnames(sel)[[1]], - sex = sex_names, - age = ages, - year = as.numeric(dimnames(sel)[[4]]), - stringsAsFactors = FALSE - ) |> - dplyr::mutate( - estimate = as.vector(sel), - label = "sel_at_age" - ) - df_sel[setdiff(tolower(names(out_new)), tolower(names(df_sel)))] <- NA - quantities_list[["sel_at_age"]] <- df_sel - } - - if ("M_at_age" %in% names(extract[[1]])) { - m_at_age <- extract[[1]][["M_at_age"]][1, seq_len(nsex), seq_along(ages), , drop = FALSE] - df_m <- expand.grid( - sex = sex_names, - age = ages, - year = as.numeric(dimnames(m_at_age)[[4]]), - stringsAsFactors = FALSE - ) |> - dplyr::mutate( - estimate = as.vector(m_at_age), - label = "m_at_age" - ) - df_m[setdiff(tolower(names(out_new)), tolower(names(df_m)))] <- NA - quantities_list[["m_at_age"]] <- df_m - } - - if (length(quantities_list) > 0) { - out_list[[names(extract)]] <- Reduce(rbind, quantities_list) |> - dplyr::mutate( - module_name = names(extract), - age = as.character(age) - ) - } - } else if (is.list(extract[[1]])) { # indicates vector and list - ##### remaining lmnts #### - 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 - ) |> - suppressWarnings() - 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 - # remove quantities inserted from other steps - df <- df |> - dplyr::filter( - label %notin% c("index_hat", "catch_h") - ) - 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 - # rbind() as above, so a module that has drifted from the standard column - # set aborts here rather than widening the output. - 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" - ) - ) + out_new <- conout_rceattle(file = file, out_new = out_new, fleet_names = fleet_names) } else { cli::cli_abort(c( message = "Output file not compatible.",