Nothing
# contains small helper functions that can be used across multiple functions in
# the r4ss pkg
#' Get the name of the data .ss_new file in a directory
#'
#' In previous versions of Stock Synthesis,
#' the file new data file was named `data.ss_new`.
#' `_echo` was added to the name when the file was parsed into three separate
#' files.
#' @param dir Relative or absolute path to a directory
#' @return A string with the name of the data .ss_new file. If not found, will
#' be NA. Both of strings are searched for using `dir(pattern = )` and
#' if both exist, then `data_echo.ss_new` is returned.
#'
get_dat_new_name <- function(dir) {
datname <- tail(
dir(path = dir, pattern = "data_?e?c?h?o?\\.ss_new"),
1
)
ifelse(length(datname) == 0, NA, datname)
}
#' Allow Multi-Plots
#' Set the par() to options suitable for ss3diags multi plots.
#'
#' See \link[graphics]{par} for more details on each parameter.
#'
#' @param mfrow determines plot frame set up
#' @param plot.cex cex graphic option
#' @param mai graphical par for plot margins
#' @param labs if TRUE margins are narrow
#' @param omi Outer margins in lines of text.
#'
#' @keywords ssplot utils
#'
#' @export
#'
sspar <- function(mfrow = c(1, 1),
plot.cex = 1,
mai = c(0.55, 0.6, 0.1, .1),
omi = c(0., 0., 0., 0) + 0.1,
labs = TRUE) {
if (labs == F) {
mai <- c(0.25, 0.25, 0.15, .15)
omi <- c(0.3, 0.35, 0.2, 0.2)
}
par(list(mfrow = mfrow, mai = mai, mgp = c(2., 0.5, 0), omi = omi, tck = -0.02, cex = plot.cex))
}
#' Convert Time-Steps
#'
#' Function to convert non-annual into annual time-steps for retros and cpue residuals
#'
#' @param ss3out outputs from r4ss::SS_output() or r4ss::SSsummarize()
#' @param time.steps time steps behind yrs e.g. 0.25 for quarterly
#' @param end.time last time step e.g. 2018.75 with a cpue observation
#'
#' @return Reformatted Rep file outputs
#'
#' @keywords utils rep retro retrocomps
#'
#' @export
#'
SSdiagsTime2Year <- function(ss3out, time.steps = 0.25, end.time) {
if (is.null(ss3out[["len"]]) == F | is.null(ss3out[["len"]]) == F) {
type <- "retrocomps"
} else {
type <- ifelse(is.null(ss3out[["modelnames"]]), "rep", "retro")
}
# Conversion match function
convTY <- function(indices, end.time, time.steps) {
steps <- (unique(indices[["Time"]]))
nsteps <- length(steps)
Time <- rev(rev(seq(0, end.time, time.steps))[1:nsteps])
Yr <- floor(Time)
Seas <- (Time - Yr) * 4 + 1
conv <- match(indices[["Time"]], steps)
indices[["Yr"]] <- Yr[conv]
indices[["Time"]] <- Time[conv]
indices[["Seas"]] <- Seas[conv]
return(indices)
}
if (type == "rep") {
ss3out[["cpue"]] <- convTY(ss3out[["cpue"]], end.time, time.steps)
# if(!is.null(ss3out[["lendbase"]])) ss3out[["lendbase"]] = convTY(ss3out[["lendbase"]],end.time,time.steps)
# length comps not working
}
if (type == "retro") {
ss3out[["indices"]] <- convTY(ss3out[["indices"]], end.time, time.steps)
# SSB
ssb <- ss3out[["SpawnBio"]]
steps <- unique(ssb[["Yr"]])
nsteps <- length(steps)
Time <- (rev(rev(seq(0, end.time, time.steps))[1:nsteps]))
ssb[["Time"]] <- Time
subset <- ssb[["Time"]] %in% floor(ssb[["Time"]])
ssb <- ssb[subset, ]
ss3out[["SpawnBio"]] <- ssb
ss3out[["SpawnBioLower"]] <- ss3out[["SpawnBioLower"]][subset, ]
ss3out[["SpawnBioUpper"]] <- ss3out[["SpawnBioUpper"]][subset, ]
ss3out[["SpawnBio"]][["Yr"]] <- ssb[["Time"]]
ss3out[["SpawnBioLower"]][["Yr"]] <- ssb[["Time"]]
ss3out[["SpawnBioUpper"]][["Yr"]] <- ssb[["Time"]]
ss3out[["startyrs"]] <- rep(min(ssb[["Time"]]), ss3out[["n"]])
ss3out[["endyrs"]] <- rep(max(ssb[["Time"]]), ss3out[["n"]])
# Can add F and Rec if needed
}
if (type == "retrocomps") {
if (!is.null(ss3out[["len"]])) ss3out[["len"]] <- convTY(ss3out[["len"]], end.time, time.steps)
if (!is.null(ss3out[["age"]])) ss3out[["len"]] <- convTY(ss3out[["age"]], end.time, time.steps)
ss3out[["startyrs"]] <- rep(min(ss3out[["len"]][["Time"]], ss3out[["age"]][["Time"]]), ss3out[["n"]])
ss3out[["endyrs"]] <- rep(max(ss3out[["len"]][["Time"]], ss3out[["age"]][["Time"]]), ss3out[["n"]])
}
return(ss3out)
}
#' Add legend to plots
#'
#' ss3diags function to add legend to plots
#'
#' @param legendlabels Optional vector of labels to include in legend.
#' @template legendloc
#' @param legendorder Optional vector of model numbers that can be used to have
#' the legend display the model names in an order that is different than that
#' which is represented in the summary input object.
#' @param legendorder Optional vector of model numbers that can be used to have
#' the legend display the model names in an order that is different than that
#' which is represented in the summary input object.
#' @param legendncol Number of columns for the legend.
#' @param legendcex Allows to adjust legend cex. Defaults to 1.
#' @param legendsp Space between legend labels
#' @param col Optional vector of colors to be used for lines. Input NULL
#' @param pch Optional vector of plot character values
#' @param lty Optional vector of line types
#' @param lwd Optional vector of line widths
#' @param type Type parameter passed to points (default 'o' overplots points on
#' top of lines)
#'
#' @export
#'
#'
add_legend <- function(legendlabels,
legendloc = "topleft",
legendorder = NULL,
legendncol = 1,
legendcex = 1,
legendsp = 0.9,
col = NULL,
pch = NULL,
lty = 1,
lwd = 2,
type = "l") {
if (is.null(legendorder)) {
legendorder <- 1:length(legendlabels)
}
if (is.numeric(legendloc)) {
Usr <- par()$usr
legendloc <- list(
x = Usr[1] + legendloc[1] * (Usr[2] - Usr[1]),
y = Usr[3] + legendloc[2] * (Usr[4] - Usr[3])
)
}
# if type input is "l" then turn off points on top of lines in legend
legend.pch <- -1
if (type == "l") {
legend.pch <- rep(NA, length(pch))
}
legend(legendloc,
legend = legendlabels[legendorder],
col = col[legendorder],
lty = lty[legendorder],
seg.len = 2,
lwd = lwd[legendorder],
pch = legend.pch[legendorder],
bty = "n",
ncol = legendncol,
pt.cex = 0.7,
cex = legendcex,
y.intersp = legendsp
)
}
#' Make a vector of colors.
#'
#' A subset of rich.colors by Arni Magnusson from the gplots package, with the
#' addition of alpha transparency (which is now available in the gplots version
#' as well)
#'
#'
#' @param n Number of colors to generate.
#' @param alpha Alpha transparency value for all colors in vector. Value is
#' passed to rgb function.
#' @author Arni Magnusson, Ian Taylor
#' @export
rich.colors.short <- function(n, alpha = 1) {
x <- seq(0, 1, length = n)
r <- 1 / (1 + exp(20 - 35 * x))
g <- pmin(pmax(0, -0.8 + 6 * x - 5 * x^2), 1)
b <- dnorm(x, 0.25, 0.15) / max(dnorm(x, 0.25, 0.15))
rgb.m <- matrix(c(r, g, b), ncol = 3)
rich.vector <- apply(rgb.m, 1, function(v) rgb(v[1], v[2], v[3], alpha = alpha))
}
#' Open png device and return info on the file being created
#'
#' this was previously contained within each of the SSplotXXX() functions.
#' It (1) translates the not-quite-matching specifications for the image to the
#' values needed by png(), then (2) returns the plotinfo data.frame
#' (which exists within each function which calls this) after adding a row
#' with the filename and caption for each new plot
#' Note: this just opens the png device which needs to be closed via dev.off()
#' outside this function.
#'
#' @param plotinfo table of information about all plots
#' @param file filename to write to (including .png extension)
#' @param plotdir directory where plots will be written
#' @template pwidth
#' @template pheight
#' @template punits
#' @template res
#' @template ptsize
#' @param caption caption for the image
#' @param alt_text alternative text for screen readers
#' (if left as NA then will be set based on the caption)
#' @param filenameprefix Additional text to append to PNG or PDF file names.
#' It will be separated from default name by an underscore.
#' @author Ian G. Taylor
#'
#' @export
save_png <- function(plotinfo,
file,
plotdir,
pwidth,
pheight,
punits,
res,
ptsize,
caption = NA,
alt_text = NA,
filenameprefix = NA) {
# replace any slashes (as in 'Eggs/kg_inter_Fem')
file <- gsub(pattern = "/", replacement = "_per_", x = file, fixed = TRUE)
if (!is.na(filenameprefix)) {
file <- paste0(filenameprefix, file)
}
# open png device
png(
filename = file.path(plotdir, file),
width = pwidth,
height = pheight,
units = punits,
res = res,
pointsize = ptsize
)
# change graphics parameters to input value
if (!is.null(par)) {
par(par)
}
# assemble and return info
invisible(rbind(plotinfo, data.frame(
file = file,
caption = caption,
alt_text = alt_text
)))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.