diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 0000000..0c817ed --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1,2 @@ +*.html +*.rds diff --git a/.github/workflows/call-doc-and-style-r.yml b/.github/workflows/call-doc-and-style-r.yml new file mode 100644 index 0000000..cca942d --- /dev/null +++ b/.github/workflows/call-doc-and-style-r.yml @@ -0,0 +1,12 @@ +# document and style R code using a reusable workflow +name: call-doc-and-style-r +# on specifies the build triggers. See more info at https://docs.github.com/en/actions/learn-github-actions/events-that-trigger-workflows +on: + # workflow_dispatch requires pushing a button to run the workflow manually. uncomment the following line to add: + workflow_dispatch: + push: + branches: [main] +jobs: + call-workflow: + uses: nmfs-fish-tools/ghactions4r/.github/workflows/doc-and-style-r.yml@main + diff --git a/.github/workflows/call-update-pkgdown.yml b/.github/workflows/call-update-pkgdown.yml new file mode 100644 index 0000000..c31bd7f --- /dev/null +++ b/.github/workflows/call-update-pkgdown.yml @@ -0,0 +1,10 @@ +on: + workflow_dispatch: + push: + branches: [main] + tags: ['*'] + +name: call-update-pkgdown +jobs: + call-workflow: + uses: nmfs-fish-tools/ghactions4r/.github/workflows/update-pkgdown.yml@main diff --git a/R/get_jitter_quants.R b/R/get_jitter_quants.R index 8946a2d..bb7d54d 100644 --- a/R/get_jitter_quants.R +++ b/R/get_jitter_quants.R @@ -20,16 +20,16 @@ get_jitter_quants <- function(mydir, model_settings, output) { est <- output[["est"]] profilesummary <- output[["profilesummary"]] - outputs <- output$profilemodels + outputs <- output[["profilemodels"]] quants <- lapply(outputs, "[[", "derived_quants") status <- sapply(sapply(outputs, "[[", "parameters", simplify = FALSE), "[[", "Status") - bounds <- apply(status, 2, function(x) rownames(outputs[[1]]$parameters)[x %in% c("LO", "HI")]) + bounds <- apply(status, 2, function(x) rownames(outputs[[1]][["parameters"]])[x %in% c("LO", "HI")]) out <- data.frame( "run" = gsub("replist", "", names(outputs)), "likelihood" = sapply(sapply(outputs, "[[", "likelihoods_used", simplify = FALSE), "[", 1, 1), "gradient" = sapply(outputs, "[[", "maximum_gradient_component"), "SB0" = sapply(quants, "[[", "SSB_Virgin", "Value"), - "SBfinal" = sapply(quants, "[[", paste0("SSB_", profilesummary$endyrs[1]), "Value"), + "SBfinal" = sapply(quants, "[[", paste0("SSB_", profilesummary[["endyrs"]][1]), "Value"), "Nparsonbounds" = apply(status, 2, function(x) sum(x %in% c("LO", "HI"))), "Lowest NLL" = ifelse(min(like) == like, "Best Fit", 0), stringsAsFactors = FALSE @@ -37,32 +37,34 @@ get_jitter_quants <- function(mydir, model_settings, output) { # Write a md file to be included in a stock assessment document # Text was pirated from @chantelwetzel-noaa's 2021 dover assessment - file_md <- file.path(jitter_dir, "model-results-jitter.md") - sink(file_md) - on.exit(sink(), add = TRUE) - cat( - sep = "", - "Model convergence was in part based on starting the minimization process ", - "from dispersed values of the maximum likelihood estimates to determine if the ", - "estimation routine results in a smaller likelihood.\n", - "Starting parameters were jittered using the built-in functionality of ", - "Stock Synthesis, where you specify a jitter fraction.\n", - "Here we used a jitter fraction of ", - round(model_settings$jitter_fraction, 2), " and the jittering was repeated ", - xfun::numbers_to_words(model_settings$Njitter), " times.\n", - "A better, i.e., lower negative log-likelihood, fit was ", - ifelse( - sum(like - est < 0) == 0, - "not found", - paste0("found for ", xfun::numbers_to_words(sum(like - est < 0)), " fits") - ), ".\n", - "Several models resulted in similar log-likelihood values ", - "with little difference in the overall model estimates, ", - "indicating a relatively flat likelihood surface around the maximum likelihood estimate.\n", - "Through the jittering analysis performed here and ", - "the estimation of likelihood profiles, ", - "we are confident that the base model as presented represents the ", - "best fit to the data given the assumptions made.\n" + utils::write.csv( + x = data.frame( + caption = paste( + sep = "", + "Model convergence was in part based on starting the minimization process ", + "from dispersed values of the maximum likelihood estimates to determine if the ", + "estimation routine results in a smaller likelihood.", + "Starting parameters were jittered using the built-in functionality of ", + "Stock Synthesis, where you specify a jitter fraction.", + "Here we used a jitter fraction of ", + round(model_settings[["jitter_fraction"]], 2), " and the jittering was repeated ", + xfun::numbers_to_words(model_settings[["Njitter"]]), " times.", + "A better, i.e., lower negative log-likelihood, fit was ", + dplyr::if_else( + sum(like - est < 0) == 0, + true = "not found", + false = paste0("found for ", xfun::numbers_to_words(sum(like - est < 0)), " fits") + ), + "Through the jittering analysis performed here and ", + "the estimation of likelihood profiles, ", + "we are confident that the base model as presented represents the ", + "best fit to the data given the assumptions made."), + alt_caption = "Comparison of the negative log-likelihood across jitter runs", + label = c("jitter", "jitter-zoomed"), + filein = file.path("..", jitter_dir, c("jitter.png", "jitter_zoomed.png")) + ), + file = file.path(jitter_dir, "jitterfigures4doc.csv"), + row.names = FALSE ) # write tables diff --git a/R/get_param_values.R b/R/get_param_values.R index c426add..d1d2e6b 100644 --- a/R/get_param_values.R +++ b/R/get_param_values.R @@ -16,36 +16,36 @@ get_param_values <- function(mydir, para = NULL, vec, summary) { x <- summary - n <- x$n - endyr <- x$endyrs[1] + 1 + n <- x[["n"]] + endyr <- x[["endyrs"]][1] + 1 out <- data.frame( - totlikelihood = as.numeric(x$likelihoods[x$likelihoods$Label == "TOTAL", 1:n]), - surveylike = as.numeric(x$likelihoods[x$likelihoods$Label == "Survey", 1:n]), - discardlike = as.numeric(x$likelihoods[x$likelihoods$Label == "Discard", 1:n]), - lengthlike = as.numeric(x$likelihoods[x$likelihoods$Label == "Length_comp", 1:n]), - agelike = as.numeric(x$likelihoods[x$likelihoods$Label == "Age_comp", 1:n]), - recrlike = as.numeric(x$likelihoods[x$likelihoods$Label == "Recruitment", 1:n]), - forerecrlike = as.numeric(x$likelihoods[x$likelihoods$Label == "Forecast_Recruitment", 1:n]), - priorlike = as.numeric(x$likelihoods[x$likelihoods$Label == "Parm_priors", 1:n]), - parmlike = as.numeric(x$likelihoods[x$likelihoods$Label == "Parm_devs", 1:n]), - R0 = as.numeric(x$pars[x$pars$Label == "SR_LN(R0)", 1:n]), - SB0 = as.numeric(x$SpawnBio[x$SpawnBio$Label == "SSB_Virgin", 1:n]), - SBfinal = as.numeric(x$SpawnBio[x$SpawnBio$Label == paste0("SSB_", endyr), 1:n]), - deplfinal = as.numeric(x$Bratio[x$Bratio$Label == paste0("Bratio_", endyr), 1:n]), - yieldspr = as.numeric(x$quants[x$quants$Label == "Dead_Catch_SPR", 1:n]), - steep = as.numeric(x$pars[x$pars$Label == "SR_BH_steep", 1:n]), - mfem = as.numeric(x$pars[x$pars$Label == "NatM_uniform_Fem_GP_1", 1:n]), - lminfem = as.numeric(x$pars[x$pars$Label == "L_at_Amin_Fem_GP_1", 1:n]), - lmaxfem = as.numeric(x$pars[x$pars$Label == "L_at_Amax_Fem_GP_1", 1:n]), - kfem = as.numeric(x$pars[x$pars$Label == "VonBert_K_Fem_GP_1", 1:n]), - cv1fem = as.numeric(x$pars[grep("young_Fem_GP_1", x$pars$Label), 1:n]), - cv2fem = as.numeric(x$pars[grep("old_Fem_GP_1", x$pars$Label), 1:n]), - mmale = as.numeric(x$pars[x$pars$Label == "NatM_uniform_Mal_GP_1", 1:n]), - lminmale = as.numeric(x$pars[x$pars$Label == "L_at_Amin_Mal_GP_1", 1:n]), - lmaxmale = as.numeric(x$pars[x$pars$Label == "L_at_Amax_Mal_GP_1", 1:n]), - kmale = as.numeric(x$pars[x$pars$Label == "VonBert_K_Mal_GP_1", 1:n]), - cv1male = as.numeric(x$pars[grep("young_Mal_GP_1", x$pars$Label), 1:n]), - cv2male = as.numeric(x$pars[grep("old_Mal_GP_1", x$pars$Label), 1:n]), + totlikelihood = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "TOTAL", 1:n]), + surveylike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Survey", 1:n]), + discardlike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Discard", 1:n]), + lengthlike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Length_comp", 1:n]), + agelike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Age_comp", 1:n]), + recrlike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Recruitment", 1:n]), + forerecrlike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Forecast_Recruitment", 1:n]), + priorlike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Parm_priors", 1:n]), + parmlike = as.numeric(x[["likelihoods"]][x[["likelihoods"]][["Label"]] == "Parm_devs", 1:n]), + R0 = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "SR_LN(R0)", 1:n]), + SB0 = as.numeric(x[["SpawnBio"]][x[["SpawnBio"]][["Label"]] == "SSB_Virgin", 1:n]), + SBfinal = as.numeric(x[["SpawnBio"]][x[["SpawnBio"]][["Label"]] == paste0("SSB_", endyr), 1:n]), + deplfinal = as.numeric(x[["Bratio"]][x[["Bratio"]][["Label"]] == paste0("Bratio_", endyr), 1:n]), + yieldspr = as.numeric(x[["quants"]][x[["quants"]][["Label"]] == "Dead_Catch_SPR", 1:n]), + steep = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "SR_BH_steep", 1:n]), + mfem = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "NatM_uniform_Fem_GP_1", 1:n]), + lminfem = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "L_at_Amin_Fem_GP_1", 1:n]), + lmaxfem = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "L_at_Amax_Fem_GP_1", 1:n]), + kfem = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "VonBert_K_Fem_GP_1", 1:n]), + cv1fem = as.numeric(x[["pars"]][grep("young_Fem_GP_1", x[["pars"]][["Label"]]), 1:n]), + cv2fem = as.numeric(x[["pars"]][grep("old_Fem_GP_1", x[["pars"]][["Label"]]), 1:n]), + mmale = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "NatM_uniform_Mal_GP_1", 1:n]), + lminmale = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "L_at_Amin_Mal_GP_1", 1:n]), + lmaxmale = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "L_at_Amax_Mal_GP_1", 1:n]), + kmale = as.numeric(x[["pars"]][x[["pars"]][["Label"]] == "VonBert_K_Mal_GP_1", 1:n]), + cv1male = as.numeric(x[["pars"]][grep("young_Mal_GP_1", x[["pars"]][["Label"]]), 1:n]), + cv2male = as.numeric(x[["pars"]][grep("old_Mal_GP_1", x[["pars"]][["Label"]]), 1:n]), stringsAsFactors = FALSE ) diff --git a/R/get_retro_quants.R b/R/get_retro_quants.R index bb0dffc..0378462 100644 --- a/R/get_retro_quants.R +++ b/R/get_retro_quants.R @@ -23,7 +23,7 @@ #' inside of an environment with `results = "asis"` #' to include a table of Mohn's rho values in a document. #' -#' `sa4ss::read_child(file.path(paste0(params$model, "_retro"), "mohnsrho.tex"))` +#' `sa4ss::read_child(file.path(paste0(params[["model"]], "_retro"), "mohnsrho.tex"))` #' #' #' @export @@ -47,7 +47,7 @@ get_retro_quants <- function(mydir, model_settings, output) { caption = paste( "Retrospective patterns for", c("spawning stock biomass (\\emph{SSB})", "fraction unfished"), - "when up to", xfun::numbers_to_words(max(abs(model_settings$retro_yr))), + "when up to", xfun::numbers_to_words(max(abs(model_settings[["retro_yrs"]]))), "years of data were removed from the base model.", "Mohn's rho (Mohn, 1999) values were", "recalculated for each peel given the removal of another year of data.", diff --git a/R/get_settings.R b/R/get_settings.R index 887937d..c4926ce 100644 --- a/R/get_settings.R +++ b/R/get_settings.R @@ -68,24 +68,24 @@ get_settings <- function(settings = NULL, verbose = FALSE) { subplots = c(1, 3) ) - Settings_all$profile_details <- get_settings_profile() + Settings_all[["profile_details"]] <- get_settings_profile() need <- !names(Settings_all) %in% names(settings) Settings_all <- c(settings, Settings_all[need]) # Check some items - if (!is.null(Settings_all$profile_details)) { - if (length(Settings_all$profile_details[is.na(Settings_all$profile_details)]) > 0) { + if (!is.null(Settings_all[["profile_details"]])) { + if (length(Settings_all[["profile_details"]][is.na(Settings_all[["profile_details"]])]) > 0) { cli::cli_abort( "Missing entry in the get_settings_profile data frame." ) } - if (!is.numeric(Settings_all$profile_details$low) & - !is.numeric(Settings_all$profile_details$high) & - !is.numeric(Settings_all$profile_details$step_size)) { + if (!is.numeric(Settings_all[["profile_details"]][["low"]]) & + !is.numeric(Settings_all[["profile_details"]][["high"]]) & + !is.numeric(Settings_all[["profile_details"]][["step_size"]])) { cli::cli_abort("There is a non-numeric value in the low, high, or step size field of the get_settings_profile data frame.") } - if (sum(!Settings_all$profile_details$param_space %in% c("real", "relative", "multiplier")) > 0) { + if (sum(!Settings_all[["profile_details"]][["param_space"]] %in% c("real", "relative", "multiplier")) > 0) { cli::cli_abort("The param_space column should be either real or relative in the get_settings_profile data frame.") } } diff --git a/R/get_summary.R b/R/get_summary.R index 8c6b07e..e80847c 100644 --- a/R/get_summary.R +++ b/R/get_summary.R @@ -22,7 +22,7 @@ get_summary <- function(mydir, para, vec, profilemodels, profilesummary) { outputs <- profilemodels quants <- lapply(outputs, "[[", "derived_quants") status <- sapply(sapply(outputs, "[[", "parameters", simplify = FALSE), "[[", "Status") - bounds <- apply(status, 2, function(x) rownames(outputs[[1]]$parameters)[x %in% c("LO", "HI")]) + bounds <- apply(status, 2, function(x) rownames(outputs[[1]][["parameters"]])[x %in% c("LO", "HI")]) out <- data.frame( "run" = gsub("replist", "", names(outputs)), @@ -31,9 +31,8 @@ get_summary <- function(mydir, para, vec, profilemodels, profilesummary) { "likelihood" = sapply(sapply(outputs, "[[", "likelihoods_used", simplify = FALSE), "[", 1, 1), "gradient" = sapply(outputs, "[[", "maximum_gradient_component"), "SB0" = sapply(quants, "[[", "SSB_Virgin", "Value"), - "SBfinal" = sapply(quants, "[[", paste0("SSB_", outputs[[1]]$endyr + 1), "Value"), - "Deplfinal" = sapply(quants, "[[", paste0("Bratio_", outputs[[1]]$endyr + 1), "Value"), - # "Fmsy" = sapply(quants, "[[", "annF_MSY", "Value"), + "SBfinal" = sapply(quants, "[[", paste0("SSB_", outputs[[1]][["endyr"]] + 1), "Value"), + "Deplfinal" = sapply(quants, "[[", paste0("Bratio_", outputs[[1]][["endyr"]] + 1), "Value"), "Nparsonbounds" = apply(status, 2, function(x) sum(x %in% c("LO", "HI"))), stringsAsFactors = FALSE ) diff --git a/R/plot_jitter.R b/R/plot_jitter.R index a18fd45..aef6e20 100644 --- a/R/plot_jitter.R +++ b/R/plot_jitter.R @@ -19,11 +19,11 @@ plot_jitter <- function(mydir, model_settings, output) { est <- output[["est"]] profilesummary <- output[["profilesummary"]] - ymax <- as.numeric(stats::quantile(unlist(profilesummary$likelihoods[1, keys]), 0.80)) + ymax <- as.numeric(stats::quantile(unlist(profilesummary[["likelihoods"]][1, keys]), 0.80)) ymin <- min(like - est) + 1 ylab <- "Change in negative log-likelihood" xlab <- "Iteration" - pngfun(wd = jitter_dir, file = paste0("Jitter_", model_settings$jitter_fraction, ".png"), h = 12, w = 9) + pngfun(wd = jitter_dir, file = "jitter.png", h = 12, w = 9) on.exit(grDevices::dev.off(), add = TRUE) plot(keys, like - est, ylim = c(ymin, ymax), cex.axis = 1.25, cex.lab = 1.25, @@ -48,7 +48,7 @@ plot_jitter <- function(mydir, model_settings, output) { ) if (ymax > 100) { - pngfun(wd = jitter_dir, file = paste0("Jitter_Zoomed_SubPlot_", model_settings$jitter_fraction, ".png"), h = 12, w = 9) + pngfun(wd = jitter_dir, file = "jitter_zoomed.png", h = 12, w = 9) on.exit(grDevices::dev.off(), add = TRUE) plot(keys, like - est, ylim = c(ymin, 100), cex.axis = 1.25, cex.lab = 1.25, diff --git a/R/plot_retro.R b/R/plot_retro.R index 0b04c7d..a7960d3 100644 --- a/R/plot_retro.R +++ b/R/plot_retro.R @@ -31,18 +31,19 @@ plot_retro <- function(mydir, model_settings, output) { legendlabels = c( "Base Model", sprintf("Data %.0f year%s", - model_settings$retro_yrs, - ifelse(abs(model_settings$retro_yrs) == 1, "", "s") + model_settings[["retro_yrs"]], + ifelse(abs(model_settings[["retro_yrs"]]) == 1, "", "s") ) ), - btarg = model_settings$btarg, - minbthresh = model_settings$minbthresh, + btarg = model_settings[["btarg"]], + minbthresh = model_settings[["minbthresh"]], ylimAdj = 1.2, plotdir = retro_dir, legendloc = "topright", print = TRUE, plot = FALSE, - pdf = FALSE + pdf = FALSE, + verbose = model_settings[["verbose"]] ) savedplotinfo <- mapply( FUN = r4ss::SSplotComparisons, @@ -52,9 +53,10 @@ plot_retro <- function(mydir, model_settings, output) { legendloc = "topleft", plotdir = retro_dir, ylimAdj = 1.2, - btarg = model_settings$btarg, - minbthresh = model_settings$minbthresh, - print = TRUE, plot = FALSE, pdf = FALSE + btarg = model_settings[["btarg"]], + minbthresh = model_settings[["minbthresh"]], + print = TRUE, plot = FALSE, pdf = FALSE, + verbose = model_settings[["verbose"]] ), subplot = c(8, 10), legendlabels = lapply( @@ -63,8 +65,8 @@ plot_retro <- function(mydir, model_settings, output) { c( "Base Model", sprintf("Data %.0f year%s (Revised Mohn's rho %.2f)", - model_settings$retro_yrs, - ifelse(abs(model_settings$retro_yrs) == 1, "", "s"), + model_settings[["retro_yrs"]], + ifelse(abs(model_settings[["retro_yrs"]]) == 1, "", "s"), rhosall[rownames(rhosall) == x, ] ) ) @@ -77,19 +79,20 @@ plot_retro <- function(mydir, model_settings, output) { legendlabels = c( "Base Model", sprintf("Data %.0f year%s", - model_settings$retro_yrs, - ifelse(abs(model_settings$retro_yrs) == 1, "", "s") + model_settings[["retro_yrs"]], + ifelse(abs(model_settings[["retro_yrs"]]) == 1, "", "s") ) ), - btarg = model_settings$btarg, - minbthresh = model_settings$minbthresh, + btarg = model_settings[["btarg"]], + minbthresh = model_settings[["minbthresh"]], subplot = c(2, 4), ylimAdj = 1.2, plotdir = retro_dir, legendloc = "topright", print = TRUE, plot = FALSE, - pdf = FALSE + pdf = FALSE, + verbose = model_settings[["verbose"]] ) savedplotinfo <- mapply( FUN = r4ss::SSplotComparisons, @@ -99,9 +102,10 @@ plot_retro <- function(mydir, model_settings, output) { legendloc = "topright", ylimAdj = 1.2, plotdir = retro_dir, - btarg = model_settings$btarg, - minbthresh = model_settings$minbthresh, - print = TRUE, plot = FALSE, pdf = FALSE + btarg = model_settings[["btarg"]], + minbthresh = model_settings[["minbthresh"]], + print = TRUE, plot = FALSE, pdf = FALSE, + verbose = model_settings[["verbose"]] ), subplot = c(2, 4), legendlabels = lapply( @@ -110,8 +114,8 @@ plot_retro <- function(mydir, model_settings, output) { c( "Base Model", sprintf("Data %.0f year%s (Revised Mohn's rho %.2f)", - model_settings$retro_yrs, - ifelse(abs(model_settings$retro_yrs) == 1, "", "s"), + model_settings[["retro_yrs"]], + ifelse(abs(model_settings[["retro_yrs"]]) == 1, "", "s"), rhosall[rownames(rhosall) == x, ] ) ) @@ -178,7 +182,7 @@ plot_retro <- function(mydir, model_settings, output) { df_out <- NULL y <- years for (a in 1:n){ - col_name <- paste0("per_diff_model", 1:n) + col_name <- paste0("per_diff_model", a) df_out <- rbind(df_out, df[df[["Yr"]] %in% y & df[["model"]] %in% col_name, ]) if (a == 1){ df_out[["model"]][df_out[["model"]] == col_name] <- "Base Model" diff --git a/R/profile_plot.R b/R/profile_plot.R index 9acf108..22f7c13 100644 --- a/R/profile_plot.R +++ b/R/profile_plot.R @@ -41,17 +41,17 @@ plot_profile <- function(mydir, rep, para, profilesummary) { exact <- TRUE } - n <- 1:profilesummary$n + n <- 1:profilesummary[["n"]] - like_comp <- unique(profilesummary$likelihoods_by_fleet$Label[ + like_comp <- unique(profilesummary[["likelihoods_by_fleet"]][["Label"]][ c( - -grep("_lambda", profilesummary$likelihoods_by_fleet$Label), - -grep("_N_use", profilesummary$likelihoods_by_fleet$Label), - -grep("_N_skip", profilesummary$likelihoods_by_fleet$Label) + -grep("_lambda", profilesummary[["likelihoods_by_fleet"]][["Label"]]), + -grep("_N_use", profilesummary[["likelihoods_by_fleet"]][["Label"]]), + -grep("_N_skip", profilesummary[["likelihoods_by_fleet"]][["Label"]]) ) ]) - ii <- which(profilesummary$likelihoods_by_fleet$Label %in% like_comp) - check <- stats::aggregate(ALL ~ Label, profilesummary$likelihoods_by_fleet[ii, ], FUN = sum) + ii <- which(profilesummary[["likelihoods_by_fleet"]][["Label"]] %in% like_comp) + check <- stats::aggregate(ALL ~ Label, profilesummary[["likelihoods_by_fleet"]][ii, ], FUN = sum) use <- check[which(check$ALL != 0), "Label"] # If present remove the likes that we don't typically show use <- use[which(!use %in% c("Disc_like", "Catch_like", "mnwt_like"))] @@ -71,7 +71,7 @@ plot_profile <- function(mydir, rep, para, profilesummary) { } # Determine the y-axis for the profile plot for all data types together - ymax1 <- max(profilesummary$likelihoods[1, n]) - min(profilesummary$likelihoods[1, n]) + ymax1 <- max(profilesummary[["likelihoods"]][1, n]) - min(profilesummary[["likelihoods"]][1, n]) if (ymax1 > 70) { ymax1 <- 70 } @@ -80,9 +80,9 @@ plot_profile <- function(mydir, rep, para, profilesummary) { } # Determine the y-axis for the piner profile plots by each data type - lab.row <- ncol(profilesummary$likelihoods) - ymax2 <- max(apply(profilesummary$likelihoods[-1, -lab.row], 1, max) - - apply(profilesummary$likelihoods[-1, -lab.row], 1, min)) + lab.row <- ncol(profilesummary[["likelihoods"]]) + ymax2 <- max(apply(profilesummary[["likelihoods"]][-1, -lab.row], 1, max) - + apply(profilesummary[["likelihoods"]][-1, -lab.row], 1, min)) if (ymax2 > 70) { ymax2 <- 70 } @@ -131,30 +131,30 @@ plot_profile <- function(mydir, rep, para, profilesummary) { ) } - maxyr <- min(profilesummary$endyrs + 1) - minyr <- max(profilesummary$startyrs) - est <- rep$parameters[rep$parameters$Label == para, "Value", 2] - sb0_est <- rep$derived_quants[rep$derived_quants$Label == "SSB_Virgin", "Value"] - sbf_est <- rep$derived_quants[rep$derived_quants$Label == paste0("SSB_", maxyr), "Value"] - depl_est <- rep$derived_quants[rep$derived_quants$Label == paste0("Bratio_", maxyr), "Value"] + maxyr <- min(profilesummary[["endyrs"]] + 1) + minyr <- max(profilesummary[["startyrs"]]) + est <- rep[["parameters"]][rep[["parameters"]][["Label"]] == para, "Value", 2] + sb0_est <- rep[["derived_quants"]][rep[["derived_quants"]][["Label"]] == "SSB_Virgin", "Value"] + sbf_est <- rep[["derived_quants"]][rep[["derived_quants"]][["Label"]] == paste0("SSB_", maxyr), "Value"] + depl_est <- rep[["derived_quants"]][rep[["derived_quants"]][["Label"]] == paste0("Bratio_", maxyr), "Value"] - x <- as.numeric(profilesummary$pars[profilesummary$pars$Label == para, n]) + x <- as.numeric(profilesummary[["pars"]][profilesummary[["pars"]][["Label"]] == para, n]) # determine whether to include the prior likelihood component in the likelihood profile starter <- r4ss::SS_readstarter(file = file.path(mydir, "starter.ss")) - like <- as.numeric(profilesummary$likelihoods[profilesummary$likelihoods$Label == "TOTAL", n] - - ifelse(starter$prior_like == 0, - profilesummary$likelihoods[profilesummary$likelihoods$Label == "Parm_priors", n], + like <- as.numeric(profilesummary[["likelihoods"]][profilesummary[["likelihoods"]][["Label"]] == "TOTAL", n] - + ifelse(starter[["prior_like"]] == 0, + profilesummary[["likelihoods"]][profilesummary[["likelihoods"]][["Label"]] == "Parm_priors", n], 0) - - rep$likelihoods_used[1, 1]) + rep[["likelihoods_used"]][1, 1]) ylike <- c(min(like) + ifelse(min(like) != 0, -0.5, 0), max(like)) - sb0 <- as.numeric(profilesummary$SpawnBio[stats::na.omit(profilesummary$SpawnBio$Label) == "SSB_Virgin", n]) - sbf <- as.numeric(profilesummary$SpawnBio[stats::na.omit(profilesummary$SpawnBio$Yr) == maxyr, n]) - depl <- as.numeric(profilesummary$Bratio[stats::na.omit(profilesummary$Bratio$Yr) == maxyr, n]) + sb0 <- as.numeric(profilesummary[["SpawnBio"]][stats::na.omit(profilesummary[["SpawnBio"]][["Label"]]) == "SSB_Virgin", n]) + sbf <- as.numeric(profilesummary[["SpawnBio"]][stats::na.omit(profilesummary[["SpawnBio"]][["Yr"]]) == maxyr, n]) + depl <- as.numeric(profilesummary[["Bratio"]][stats::na.omit(profilesummary[["Bratio"]][["Yr"]]) == maxyr, n]) # Get the relative management targets - only grab the first element since the targets should be the same - btarg <- as.numeric(profilesummary$btarg[1]) - thresh <- as.numeric(profilesummary$minbthresh[1]) # ifelse(btarg == 0.40, 0.25, ifelse(btarg == 0.25, 0.125, -1)) + btarg <- as.numeric(profilesummary[["btargs"]][1]) + thresh <- as.numeric(profilesummary[["minbthreshs"]][1]) pngfun(wd = mydir, file = paste0("parameter_panel_", para, ".png"), h = 7, w = 7) on.exit(grDevices::dev.off(), add = TRUE) @@ -181,26 +181,23 @@ plot_profile <- function(mydir, rep, para, profilesummary) { # parameter vs. SB0 plot(x, sb0, type = "l", lwd = 2, xlab = label, - ylab = ifelse(profilesummary$SpawnOutputUnits[1] == "numbers", + ylab = ifelse(profilesummary[["SpawnOutputUnits"]][1] == "numbers", expression(SO[0]), expression(SB[0])), ylim = c(0, max(sb0))) points(est, sb0_est, pch = 21, col = "black", bg = "blue", cex = 1.5) # parameter vs. SBfinal plot(x, sbf, type = "l", lwd = 2, xlab = label, - ylab = ifelse(profilesummary$SpawnOutputUnits[1] == "numbers", + ylab = ifelse(profilesummary[["SpawnOutputUnits"]][1] == "numbers", expression(SO[final]), expression(SB[final])), ylim = c(0, max(sbf))) points(est, sbf_est, pch = 21, col = "black", bg = "blue", cex = 1.5) # Create the sb and depl trajectories plot # Figure out what the base model parameter is in order to label that in the plot - get <- ifelse(para == "SR_LN(R0)", "log(R0)", - ifelse(para %in% c("NatM_uniform_Fem_GP_1", "NatM_p_1_Fem_GP_1"), "M (f)", - ifelse(para %in% c("NatM_uniform_Mal_GP_1", "NatM_p_1_Mal_GP_1"), "M (m)", - ifelse(para == "SR_BH_steep", "h", - para - ) - ) - ) + get <- dplyr::case_when( + para == "SR_LN(R0)" ~ "log(R0)", + para %in% c("NatM_uniform_Fem_GP_1", "NatM_p_1_Fem_GP_1") ~ "M (f)", + para %in% c("NatM_uniform_Mal_GP_1", "NatM_p_1_Mal_GP_1") ~ "M (m)", + para == "SR_BH_steep" ~ "h" ) r4ss::SSplotComparisons( @@ -217,7 +214,7 @@ plot_profile <- function(mydir, rep, para, profilesummary) { btarg = btarg, minbthresh = thresh, plotdir = mydir, - subplots = profilesummary$subplots, + subplots = profilesummary[["subplots"]], pdf = FALSE, print = TRUE, plot = FALSE, filenameprefix = paste0(para, "_trajectories_") ) diff --git a/R/profile_wrapper.R b/R/profile_wrapper.R index 062f280..0b3ea26 100644 --- a/R/profile_wrapper.R +++ b/R/profile_wrapper.R @@ -48,9 +48,9 @@ profile_wrapper <- function(mydir, model_settings) { get_summary( mydir = output[["mydir"]], para = para, - vec = output$profilesummary$pars %>% - dplyr::filter(Label == para) %>% - dplyr::select(dplyr::starts_with("rep")) %>% + vec = output[["profilesummary"]][["pars"]] |> + dplyr::filter(Label == para) |> + dplyr::select(dplyr::starts_with("rep")) |> as.vector(), profilemodels = output[["profilemodels"]], profilesummary = output[["profilesummary"]] diff --git a/R/run_diagnostics.R b/R/run_diagnostics.R index 4e722b5..dd2d4fe 100644 --- a/R/run_diagnostics.R +++ b/R/run_diagnostics.R @@ -13,12 +13,12 @@ run_diagnostics <- function(mydir, model_settings) { - exe <- r4ss::check_exe(exe = model_settings$exe, dir = file.path(mydir, model_settings$base_name))[["exe"]] - model_settings$exe <- exe + exe <- r4ss::check_exe(exe = model_settings$exe, dir = file.path(mydir, model_settings[["base_name"]]))[["exe"]] + model_settings[["exe"]] <- exe '%>%' <- magrittr::'%>%' # Check for Report file - model_dir <- file.path(mydir, paste0(model_settings$base_name)) + model_dir <- file.path(mydir, paste0(model_settings[["base_name"]])) if (!file.exists(file.path(model_dir, "Report.sso"))) { orig_dir <- getwd() @@ -26,23 +26,23 @@ run_diagnostics <- function(mydir, model_settings) { cli::cli_info("Running model in directory: {getwd()}") r4ss::run( dir = model_dir, - exe = model_settings$exe, - extras = model_settings$extras, + exe = model_settings[["exe"]], + extras = model_settings[["extras"]], skipfinished = FALSE, - verbose = model_settings$verbose + verbose = model_settings[["verbose"]] ) setwd(orig_dir) } - if ("retro" %in% model_settings$run) { + if ("retro" %in% model_settings[["run"]]) { retro_wrapper(mydir = mydir, model_settings = model_settings) } - if ("profile" %in% model_settings$run) { + if ("profile" %in% model_settings[["run"]]) { profile_wrapper(mydir = mydir, model_settings = model_settings) } - if ("jitter" %in% model_settings$run) { + if ("jitter" %in% model_settings[["run"]]) { jitter_wrapper(mydir = mydir, model_settings = model_settings) } } diff --git a/R/run_jitter.R b/R/run_jitter.R index 8bcbb16..70c2474 100644 --- a/R/run_jitter.R +++ b/R/run_jitter.R @@ -15,18 +15,18 @@ #' @export run_jitter <- function(mydir, model_settings) { - if (!file.exists(file.path(mydir, model_settings$base_name, "Report.sso"))) { + if (!file.exists(file.path(mydir, model_settings[["base_name"]], "Report.sso"))) { + base <- model_settings[["base_name"]] cli::cli_abort("There is no Report.sso file in the base model directory: - {file.path(mydir, model_settings$base_name}") - + {file.path(mydir, base}") } # Create a jitter folder with the same naming structure as the base model - jitter_dir <- file.path(mydir, paste0(model_settings$base_name, "_jitter_", model_settings$jitter_fraction)) + jitter_dir <- file.path(mydir, paste0(model_settings[["base_name"]], "_jitter_", model_settings[["jitter_fraction"]])) dir.create(jitter_dir, showWarnings = FALSE) - all_files <- list.files(file.path(mydir, model_settings$base_name)) + all_files <- list.files(file.path(mydir, model_settings[["base_name"]])) utils::capture.output(file.copy( - from = file.path(mydir, model_settings$base_name, all_files), + from = file.path(mydir, model_settings[["base_name"]], all_files), to = jitter_dir, overwrite = TRUE ), file = "run_diag_warning.txt") @@ -34,23 +34,23 @@ run_jitter <- function(mydir, model_settings) { r4ss::jitter( dir = jitter_dir, - exe = model_settings$exe, - Njitter = model_settings$Njitter, - printlikes = model_settings$printlikes, - verbose = model_settings$verbose, - jitter_fraction = model_settings$jitter_fraction, - init_values_src = model_settings$jitter_init_values_src, - extras = model_settings$extras + exe = model_settings[["exe"]], + Njitter = model_settings[["Njitter"]], + printlikes = model_settings[["printlikes"]], + verbose = model_settings[["verbose"]], + jitter_fraction = model_settings[["jitter_fraction"]], + init_values_src = model_settings[["jitter_init_values_src"]], + extras = model_settings[["extras"]] ) #### Read in results using other r4ss functions - keys <- 1:model_settings$Njitter + keys <- 1:model_settings[["Njitter"]] profilemodels <- r4ss::SSgetoutput( dirvec = jitter_dir, keyvec = keys, getcovar = FALSE, forecast = FALSE, - verbose = FALSE, + verbose = model_settings[["verbose"]], listlists = TRUE, underscore = FALSE, save.lists = FALSE @@ -68,18 +68,18 @@ run_jitter <- function(mydir, model_settings) { ) est <- base$likelihoods_used[1, 1] - like <- as.numeric(profilesummary$likelihoods[1, keys]) - ymax <- as.numeric(stats::quantile(unlist(profilesummary$likelihoods[1, keys]), 0.80)) + like <- as.numeric(profilesummary[["likelihoods"]][1, keys]) + ymax <- as.numeric(stats::quantile(unlist(profilesummary[["likelihoods"]][1, keys]), 0.80)) ymin <- min(like - est) + 1 jitter_output <- list() - jitter_output$plotdir <- jitter_dir - jitter_output$est <- est - jitter_output$keys <- keys - jitter_output$like <- like - jitter_output$model_settings <- model_settings - jitter_output$profilesummary <- profilesummary - jitter_output$profilemodels <- profilemodels + jitter_output[["plotdir"]] <- jitter_dir + jitter_output[["est"]] <- est + jitter_output[["keys"]] <- keys + jitter_output[["like"]] <- like + jitter_output[["model_settings"]] <- model_settings + jitter_output[["profilesummary"]] <- profilesummary + jitter_output[["profilemodels"]] <- profilemodels save( jitter_dir, diff --git a/R/run_profile.R b/R/run_profile.R index 708af97..d0916a8 100644 --- a/R/run_profile.R +++ b/R/run_profile.R @@ -38,28 +38,28 @@ run_profile <- function(mydir, model_settings, para) { # Create a profile folder with the same naming structure as the base model # Add a label to show if prior was used or not - profile_dir <- file.path(mydir, paste0(model_settings$base_name, "_profile_", para)) + profile_dir <- file.path(mydir, paste0(model_settings[["base_name"]], "_profile_", para)) dir.create(profile_dir, showWarnings = FALSE) # Check for existing files and delete - if (model_settings$remove_files & length(list.files(profile_dir)) != 0) { + if (model_settings[["remove_files"]] & length(list.files(profile_dir)) != 0) { remove <- list.files(profile_dir) file.remove(file.path(profile_dir, remove)) } - all_files <- list.files(file.path(mydir, model_settings$base_name)) + all_files <- list.files(file.path(mydir, model_settings[["base_name"]])) utils::capture.output(file.copy( - from = file.path(mydir, model_settings$base_name, all_files), + from = file.path(mydir, model_settings[["base_name"]], all_files), to = profile_dir, overwrite = TRUE ), file = "run_diag_warning.txt") cli::cli_inform("Running profile for {para}.") # check for whether oldctlfile exists - if (!file.exists(file.path(profile_dir, model_settings$oldctlfile))) { + if (!file.exists(file.path(profile_dir, model_settings[["oldctlfile"]]))) { # if the oldctlfile is control.ss_new, and doesn't exist, # run the model to create it - if (model_settings$oldctlfile == "control.ss_new") { - if (model_settings$verbose) { + if (model_settings[["oldctlfile"]] == "control.ss_new") { + if (model_settings[["verbose"]]) { message("running model to get control.ss_new file") } r4ss::run( @@ -70,64 +70,64 @@ run_profile <- function(mydir, model_settings, para) { verbose = model_settings[["verbose"]] ) } else { - cli::cli_abort("Can not find {model_settings$oldctlfile}") + oldctlfile <- model_settings[["oldctlfile"]] + cli::cli_abort("Can not find {ctl_file}") } } # Use the SS_parlines function to ensure that the input parameter can be found check_para <- r4ss::SS_parlines( - ctlfile = model_settings$oldctlfile, + ctlfile = model_settings[["oldctlfile"]], dir = profile_dir, verbose = FALSE, - version = model_settings$version, + version = model_settings[["version"]], active = FALSE )$Label == para if (sum(check_para) == 0) { - print(para) - cli::cli_abort("The input profile_custom does not match a parameter in the file - {model_settings$oldctlfile}") + oldctlfile <- model_settings[["oldctlfile"]] + cli::cli_abort("The input of {para} does not match a parameter in the file {oldctlfile}") } # Copy oldctlfile to newctlfile before modifying it - file.copy(file.path(profile_dir, model_settings$oldctlfile), - file.path(profile_dir, model_settings$newctlfile)) + file.copy(file.path(profile_dir, model_settings[["oldctlfile"]]), + file.path(profile_dir, model_settings[["newctlfile"]])) # Change the control file name in the starter file starter <- r4ss::SS_readstarter(file = file.path(profile_dir, "starter.ss")) - starter$ctlfile <- model_settings$newctlfile - starter$init_values_src <- model_settings$init_values_src + starter[["ctlfile"]] <- model_settings[["newctlfile"]] + starter[["init_values_src"]] <- model_settings[["init_values_src"]] r4ss::SS_writestarter(mylist = starter, dir = profile_dir, overwrite = TRUE) # Read in the base model rep <- r4ss::SS_output( - file.path(mydir, model_settings$base_name), + file.path(mydir, model_settings[["base_name"]]), covar = FALSE, printstats = FALSE, verbose = FALSE ) - est <- rep$parameters[rep$parameters$Label == para, "Value"] + est <- rep[["parameters"]][rep[["parameters"]][["Label"]] == para, "Value"] # Determine the parameter range - if (model_settings$profile_details$param_space == "relative") { + if (model_settings[["profile_details"]][["param_space"]] == "relative") { range <- c( - est + model_settings$profile_details$low, - est + model_settings$profile_details$high + est + model_settings[["profile_details"]][["low"]], + est + model_settings[["profile_details"]][["high"]] ) } - if (model_settings$profile_details$param_space == "multiplier") { + if (model_settings[["profile_details"]][["param_space"]] == "multiplier") { range <- c( - est - est * model_settings$profile_details$low, - est + est * model_settings$profile_details$high + est - est * model_settings[["profile_details"]][["low"]], + est + est * model_settings[["profile_details"]][["high"]] ) } - if (model_settings$profile_details$param_space == "real") { + if (model_settings[["profile_details"]][["param_space"]] == "real") { range <- c( - model_settings$profile_details$low, - model_settings$profile_details$high + model_settings[["profile_details"]][["low"]], + model_settings[["profile_details"]][["high"]] ) } - step_size <- model_settings$profile_details$step_size + step_size <- model_settings[["profile_details"]][["step_size"]] # Create parameter vect from base down and the base up if (est != round_any(est, step_size, f = floor)) { @@ -149,51 +149,51 @@ run_profile <- function(mydir, model_settings, para) { } vec <- c(low, high) - num <- sort(vec, index.return = TRUE)$ix + num <- sort(vec, index.return = TRUE)[["ix"]] # backup original control.ss_new file for use in second half of profile - file.copy(file.path(profile_dir, model_settings$oldctlfile), + file.copy(file.path(profile_dir, model_settings[["oldctlfile"]]), file.path(profile_dir, "backup_oldctlfile.ss"), overwrite = model_settings$overwrite) # backup original par file for use in second half of profile # if usepar = TRUE file.copy(file.path(profile_dir, "ss.par"), file.path(profile_dir, "backup_ss.par"), - overwrite = model_settings$overwrite) + overwrite = model_settings[["overwrite"]]) # loop over down, then up for (iprofile in 1:2) { whichruns <- which(vec %in% if(iprofile == 1){low} else {high}) - if (!is.null(model_settings$whichruns)) { - whichruns <- intersect(model_settings$whichruns, whichruns) + if (!is.null(model_settings[["whichruns"]])) { + whichruns <- intersect(model_settings[["whichruns"]], whichruns) } if (iprofile == 2) { # copy backup back to use in second half of profile file.copy(file.path(profile_dir, "backup_oldctlfile.ss"), - file.path(profile_dir, model_settings$oldctlfile)) + file.path(profile_dir, model_settings[["oldctlfile"]])) # copy backup back to use in second half of profile file.copy(file.path(profile_dir, "backup_ss.par"), file.path(profile_dir, "ss.par"), - overwrite = model_settings$overwrite) + overwrite = model_settings[["overwrite"]]) } profile <- r4ss::profile( dir = profile_dir, - oldctlfile = model_settings$oldctlfile, - newctlfile = model_settings$newctlfile, - linenum = model_settings$linenum, + oldctlfile = model_settings[["oldctlfile"]], + newctlfile = model_settings[["newctlfile"]], + linenum = model_settings[["linenum"]], string = para, profilevec = vec, - usepar = model_settings$usepar, - globalpar = model_settings$globalpar, - parlinenum = model_settings$parlinenum, - parstring = model_settings$parstring, - saveoutput = model_settings$saveoutput, - overwrite = model_settings$overwrite, + usepar = model_settings[["usepar"]], + globalpar = model_settings[["globalpar"]], + parlinenum = model_settings[["parlinenum"]], + parstring = model_settings[["parstring"]], + saveoutput = model_settings[["saveoutput"]], + overwrite = model_settings[["overwrite"]], whichruns = whichruns, # values set above - prior_check = model_settings$prior_check, - exe = model_settings$exe, - verbose = model_settings$verbose, - extras = model_settings$extras + prior_check = model_settings[["prior_check"]], + exe = model_settings[["exe"]], + verbose = model_settings[["verbose"]], + extras = model_settings[["extras"]] ) } @@ -204,23 +204,23 @@ run_profile <- function(mydir, model_settings, para) { profilemodels <- r4ss::SSgetoutput(dirvec = profile_dir, keyvec = num) profilesummary <- r4ss::SSsummarize(biglist = profilemodels) - if(!is.null(model_settings$btarg)){ - profilesummary$btarg <- model_settings$btarg - profilesummary$minbthresh <- model_settings$minbthresh + if(!is.null(model_settings[["btarg"]])){ + profilesummary[["btarg"]] <- model_settings[["btarg"]] + profilesummary[["minbthresh"]] <- model_settings[["minbthresh"]] } - profilesummary$subplots <- model_settings$subplots + profilesummary[["subplots"]] <- model_settings[["subplots"]] profile_output <- list() - profile_output$mydir <- profile_dir - profile_output$para <- para - profile_output$name <- paste0("profile_", para) - profile_output$vec <- vec[num] - profile_output$model_settings <- model_settings - profile_output$profilemodels <- profilemodels - profile_output$profilesummary <- profilesummary - profile_output$rep <- rep - profile_output$vec_unordered <- vec - profile_output$num <- num + profile_output[["mydir"]] <- profile_dir + profile_output[["para"]] <- para + profile_output[["name"]] <- paste0("profile_", para) + profile_output[["vec"]] <- vec[num] + profile_output[["model_settings"]] <- model_settings + profile_output[["profilemodels"]] <- profilemodels + profile_output[["profilesummary"]] <- profilesummary + profile_output[["rep"]] <- rep + profile_output[["vec_unordered"]] <- vec + profile_output[["num"]] <- num save( profile_dir, diff --git a/R/run_retro.R b/R/run_retro.R index 2ecd7a0..9f8a475 100644 --- a/R/run_retro.R +++ b/R/run_retro.R @@ -34,7 +34,7 @@ #' inside of an environment with `results = "asis"` #' to include a table of Mohn's rho values in a document. #' -#' `sa4ss::read_child(file.path(paste0(params$model, "_retro"), "mohnsrho.tex"))` +#' `sa4ss::read_child(file.path(paste0(params[["model"]], "_retro"), "mohnsrho.tex"))` #' #' * `retro_output.Rdata` with a list of R objects. #' @@ -42,18 +42,17 @@ run_retro <- function(mydir, model_settings) { - if(!file.exists(file.path(mydir, model_settings$base_name, "Report.sso"))) { - cli::cli_abort("There is no Report.sso file in the base model directory - {file.path(mydir, model_settings$base_name)}") - + if(!file.exists(file.path(mydir, model_settings[["base_name"]], "Report.sso"))) { + base <- model_settings[["base_name"]] + cli::cli_abort("There is no Report.sso file in the base model directory {file.path(mydir, base}") } # Create a jitter folder with the same naming structure as the base model - retro_dir <- file.path(mydir, paste0(model_settings$base_name, "_retro_", length(model_settings$retro_yrs), "_yr_peel")) + retro_dir <- file.path(mydir, paste0(model_settings[["base_name"]], "_retro_", length(model_settings[["retro_yrs"]]), "_yr_peel")) dir.create(retro_dir, showWarnings = FALSE) - all_files = list.files(file.path(mydir, model_settings$base_name)) + all_files = list.files(file.path(mydir, model_settings[["base_name"]])) ignore <- file.copy( - from = file.path(mydir, model_settings$base_name, all_files), + from = file.path(mydir, model_settings[["base_name"]], all_files), to = retro_dir, overwrite = TRUE ) @@ -61,29 +60,30 @@ run_retro <- function(mydir, model_settings) { r4ss::retro( dir = retro_dir, - oldsubdir = model_settings$oldsubdir, - newsubdir = model_settings$newsubdir, - years = model_settings$retro_yrs, - overwrite = model_settings$overwrite, - exe = model_settings$exe, - extras = model_settings$extras, - show_in_console = model_settings$show_in_console + oldsubdir = model_settings[["oldsubdir"]], + newsubdir = model_settings[["newsubdir"]], + years = model_settings[["retro_yrs"]], + overwrite = model_settings[["overwrite"]], + exe = model_settings[["exe"]], + extras = model_settings[["extras"]], + show_in_console = model_settings[["show_in_console"]], + verbose = model_settings[["verbose"]] ) ignore <- file.remove(from = file.path(retro_dir, all_files)) runs <- list() - for(aa in 1:(length(model_settings$retro_yrs) + 1)) { + for(aa in 1:(length(model_settings[["retro_yrs"]]) + 1)) { if (aa == 1) { - runs[[aa]] <- r4ss::SS_output(dir = file.path(mydir, model_settings$base_name), verbose = FALSE, printstats = FALSE) + runs[[aa]] <- r4ss::SS_output(dir = file.path(mydir, model_settings[["base_name"]]), verbose = FALSE, printstats = FALSE) } else { - tmp = file.path(retro_dir, model_settings$newsubdir, paste0("retro", model_settings$retro_yrs[aa-1])) + tmp = file.path(retro_dir, model_settings[["newsubdir"]], paste0("retro", model_settings[["retro_yrs"]][aa-1])) runs[[aa]] <- r4ss::SS_output(dir = tmp, verbose = FALSE, printstats = FALSE) } } - retroSummary <- r4ss::SSsummarize(biglist = runs, verbose = FALSE) - endyrvec <- c(retroSummary$endyrs[1], retroSummary$endyrs[1] + model_settings$retro_yrs) + retroSummary <- r4ss::SSsummarize(biglist = runs, verbose = model_settings[["verbose"]]) + endyrvec <- c(retroSummary[["endyrs"]][1], retroSummary[["endyrs"]][1] + model_settings[["retro_yrs"]]) # Calculate Mohn's rho rhosall <- mapply( @@ -92,13 +92,13 @@ run_retro <- function(mydir, model_settings) { seq_along(runs)[-1], function(x) r4ss::SSsummarize(runs[1:x], verbose = FALSE) ), - endyrvec = mapply(seq,from=endyrvec[1], to= endyrvec[-1]) + verbose = model_settings[["verbose"]], + endyrvec = mapply(seq, from = endyrvec[1], to = endyrvec[-1]) ) - rhos <- rhosall %>% - data.frame %>% - dplyr::select(values = NCOL(rhosall)) %>% - tibble::rownames_to_column("ind") %>% + rhos <- data.frame(rhosall) |> + dplyr::select(values = NCOL(rhosall)) |> + tibble::rownames_to_column("ind") |> dplyr::mutate( ind = gsub("\\.all$", "", ind), Quantity = gsub("[A-Za-z_]+_([A-Za-z]+$)|(^[A-Za-z]+$)", "\\1\\2", ind), @@ -108,8 +108,8 @@ run_retro <- function(mydir, model_settings) { ind = gsub("^$", "Mohn", ind), ind = gsub("WoodHole", "NEFSC", ind), ind = gsub("_Hurtado", "", ind), - ) %>% - dplyr::rename(type = "ind") %>% + ) |> + dplyr::rename(type = "ind") |> dplyr::select(type, Quantity, values) utils::write.csv( x = as.matrix(rhos), @@ -118,12 +118,12 @@ run_retro <- function(mydir, model_settings) { ) retro_output <- list() - retro_output$plotdir <- retro_dir - retro_output$endyrvec <- endyrvec - retro_output$retroSummary <- retroSummary - retro_output$model_settings <- model_settings - retro_output$rhosall <- rhosall - retro_output$rhos <- rhos + retro_output[["plotdir"]] <- retro_dir + retro_output[["endyrvec"]] <- endyrvec + retro_output[["retroSummary"]] <- retroSummary + retro_output[["model_settings"]] <- model_settings + retro_output[["rhosall"]] <- rhosall + retro_output[["rhos"]] <- rhos save( retro_dir, diff --git a/man/get_retro_quants.Rd b/man/get_retro_quants.Rd index dd2d4d0..9a05aba 100644 --- a/man/get_retro_quants.Rd +++ b/man/get_retro_quants.Rd @@ -39,7 +39,7 @@ The following objects are saved to the disk. inside of an environment with \code{results = "asis"} to include a table of Mohn's rho values in a document. -\code{sa4ss::read_child(file.path(paste0(params$model, "_retro"), "mohnsrho.tex"))} +\code{sa4ss::read_child(file.path(paste0(params[["model"]], "_retro"), "mohnsrho.tex"))} } } \description{ diff --git a/man/run_retro.Rd b/man/run_retro.Rd index 7d38abe..f41caf5 100644 --- a/man/run_retro.Rd +++ b/man/run_retro.Rd @@ -41,7 +41,7 @@ complete with captions and alternative text. inside of an environment with \code{results = "asis"} to include a table of Mohn's rho values in a document. -\code{sa4ss::read_child(file.path(paste0(params$model, "_retro"), "mohnsrho.tex"))} +\code{sa4ss::read_child(file.path(paste0(params[["model"]], "_retro"), "mohnsrho.tex"))} \item \code{retro_output.Rdata} with a list of R objects. } } diff --git a/vignettes/.gitignore b/vignettes/.gitignore new file mode 100644 index 0000000..849ed1a --- /dev/null +++ b/vignettes/.gitignore @@ -0,0 +1,3 @@ +*.html +*.R +nwfscDiag_files diff --git a/vignettes/nwfscDiag.qmd b/vignettes/nwfscDiag.qmd new file mode 100644 index 0000000..86bb5d6 --- /dev/null +++ b/vignettes/nwfscDiag.qmd @@ -0,0 +1,192 @@ +--- +title: "nwfscDiag" +author: "Chantel Wetzel" +format: html +editor: visual +--- + +# nwfscDiag: Diagnostic Package for West Coast Groundfish Assessments + +The package provides the functionality to conduct model diagnostics for Stock Synthesis (SS3) models. The standard diagnostic included in this package are standard required analysis for U.S. West Coast Groundfish stock assessments managed by the Pacific Fisheries Management Council. The package was designed to perform model diagnostics and create plots and tables in a standardized format. The standardized approach will facilitate the use of these outputs in the assessment template approach. + +The diagnostics created by the package are: - jitter runs to ensure model convergence at the Maximum Likelihood Estimate (MLE), - retrospective runs to examine model sensitivity to recent data, and\ +- likelihood profiles across parameters. + +This package does not maintain backward compatibility with previous versions of Stock Synthesis. However, if needed user can download older package versions that may work with older versions (3.30.+) of Stock Synthesis. + +## Installation + +nwfscDiag can be installed via github: + +``` +install.packages("remotes") +remotes::install_github("pfmc-assessments/nwfscDiag") +``` + +## Running the code + +The package depends upon a few other packages and they should be installed upon installation of the package. The dependent packages are: + +``` +install.packages('dplyr') +remotes::install_github('r4ss/r4ss') +``` + +A new version of r4ss package was released on July 29, 2022 that included some significant changes that are required for the current version of `nwfscDiag` to run. The current version of the nwfscDiag 1.1.2 package is designed to work with the latest release of r4ss. Please see release version 1.0.1 to use earlier versions of r4ss. + +## Example: Run all diagnostics + +First, you should specify the directory where the base model is located and where the diagnostics will be run and the name of the base model folder: + +``` +library(nwfscDiag) +directory <- "C:/your directory" +base_model_name <- "base model" +``` + +Another way to do handle directory management is by using a project file and the `here` package: + +``` +directory <- here::here("models") +base_model_name <- "base model" +``` + +The `get_settings_profile()` specifies which parameters to run a profile for and the parameter ranges for each profile. The low and high values can be specified in 3 ways: + +- as a 'multiplier' where a percent where the low and high range will be specified as x% of the base parameter (i.e., (base parameter - base parameter\* x) - (base parameter + base parameter \* x)), +- in 'real' space where the low and high values are in the parameter space, and +- as 'relative' where the low and high is a specified amount relative to the base model parameter (i.e., (base parameter - x) - (base parameter + x). + +Specify the parameters to profile over along with the parameter range and step size: + +``` +profile_info <- get_settings_profile( + parameters = c("NatM_uniform_Fem_GP_1", "SR_BH_steep", "SR_LN(R0)"), + low = c(0.40, 0.25, -2), + high = c(0.40, 1.0, 2), + step_size = c(0.005, 0.05, 0.25), + param_space = c('multiplier', 'real', 'relative') + ) +``` + +The `parameters` function argument specifies the parameters to profile over where the string provided should match the string label in the SS3 control file. The `low`, `high`, `step_size`, and `param_space` inputs should be vectors of equal length to the `parameters` input. The above example will profile over female natural mortality, steepness, and $R_0$. The female natural mortality parameter profile will range from (base parameter - base parameter\* x) to (base parameter + base parameter \* x) in steps of 0.005, the steepness parameter profile will range from 0.25 to 1.0 in step size of 0.05, and the $R_0$ parameter profile will range from ($R_0$ - 0.25) to ($R_0$ + 0.25) in step size of 0.25. + +Next the settings for running the profiles, jitter, and retrospectives within `r4ss` needs to be specified using `get_settings()`: + +``` +model_settings <- get_settings( + settings = list( + base_name = base_model_name, + run = c("jitter", "profile", "retro"), + profile_details = profile_info ) + ) +``` + +where the above example requests jitters, profiles, and retrospective models to be run for the model file specified above as the `base_model_name` with the profile setting set using `get_settings_profile()` above. Calling `model_settings` in the R terminal will show all default settings. + +If `profile` is included in the run requested and `verbose = TRUE` in the `model_settings()` the values for each parameter profiled across will be printed to the screen. Reviewing this information prior to running all diagnostics can be useful to ensure the parameter range and step size was set correctly. + +Run all diagnostics: + +``` +run_diagnostics(mydir = directory, model_settings = model_settings) +``` + +## Example: Run a single profile + +``` +library(nwfscDiag) +directory <- here::here("models") +base_model_name <- "base model" + +profile_settings <- get_settings_profile( + parameters = c("SR_BH_steep"), + low = c(0.25), + high = c(1.0), + step_size = c(0.05), + param_space = c('real') + ) + +model_settings <- get_settings( + settings = list( + base_name = base_model_name, + run = "profile", + profile_details = profile_settings) + ) + +run_diagnostics(mydir = directory, model_settings = model_settings) +``` + +## Example: Run jitters + +``` +library(nwfscDiag) +directory <- here::here("models") +base_model_name <- "base model" + +model_settings <- get_settings( + settings = list( + base_name = base_model_name, + run = "jitter", + Njitter = 100, + jitter_fraction = 0.10) + ) + +run_diagnostics(mydir = directory, model_settings = model_settings) +``` + +## Example: Run retrospectives + +``` +library(nwfscDiag) +directory <- here::here("models") +base_model_name <- "base model" + +model_settings <- get_settings( + settings = list( + base_name = base_model_name, + run = "retro", + retro_yrs = -1:-10) + ) + +run_diagnostics(mydir = directory, model_settings = model_settings) +``` + +## Example: Rerun select values for a profile + +There are instances where not all models runs within a parameter profile converge. In this case one needs to rerun only select models that failed to converge in the profile. The `rerun_profile_vals()` function allows users to do this. + +``` +library(nwfscDiag) +directory <- here::here("models") +base_model_name <- "base model" +rerun_profile_vals( + mydir = file.path(model_dir, base_name), + model_settings = model_settings, + para_name = "SR_LN(R0)", + run_num = c(6, 4,3,2), + data_file_nm = "base_model_data_file.dat") +``` + +where the `run_num` is the number reported in the profile_SR_LN(RO))\_results.csv file under the run column. Profiles are run out from the base model parameter value to lower or higher values to improve model convergence and hence, the run number reported in the csv is not sequential from the lower to upper bounds. + +## Example: Run jitters in parrallel + +`r4ss` v1.49.3+ supports running models in parallel. This can be particularly helpful when running jitters. In order to run jitters in parallel, additional specifications are needed outside the `nwfscDiag` package and some additional R packages (`parallelly`, `future`) need to be installed: + +``` +ncores <- parallelly::availableCores(omit = 1) +future::plan(future::multisession, workers = ncores) + +model_settings <- get_settings(settings = list( + exe = "ss3", + base_name = base_model, + run = "jitter", + Njitter = 100, + jitter_fraction = 0.10)) + +run_diagnostics(mydir = dir, model_settings = model_settings) +future::plan(future::sequential) +``` + +This same approach could be done with profiles, but is not recommended for models with convergence issues.