/
setup_scenarios.R
367 lines (354 loc) · 12.4 KB
/
setup_scenarios.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
#' Set up fleet-specific information
#'
#' Sometimes, users will want to pass a single input instead of fleet-specific
#' information to make things easier to keep track of for the user.
#' `get_fleet` copies this single object over to all fleets
#' for a given sampling type.
#'
#' @details
#' In the data frame that stores scenario-specific information by row,
#' columns are fleet-specific with the fleet denoted after the last full stop.
#' If this terminal full stop followed by a numerical value is not supplied,
#' then the value will be copied for all fleets.
#' For example, `sa.Nsamp.1` specifies the sample size for age-composition data
#' for fleet number one. Whereas, `sa.Nsamp` specifies the input sample-size
#' for all fleets.
#'
#' A todo list for future features is as follows:
#' * remove fleets that have NA
#' * allow for arguments rather than hardwiring arg and fleet
#' * see if sa.Nsamp and sa.Nsamp.1 can be in the same data frame and just
#' fill in the value for fleets that aren't specified; would need to fill
#' up and down I think within a group to make it work.
#' * accomodate -999 in sample function cpar arguments
#' * create add_args to fill in missing arguments across fleets
#' * implement add_args before expand fleet such that the new
#' arg would be expanded for all fleets but I only have to specify
#' the default one time
#' * fix `.data[[""]]` to pass CRAN
#' x <- enquo(x)
#' y <- enquo(y)
#' ggplot(data) + geom_point(aes(!!x, !!y))
#'
#' @param data A data frame of scenario information that was passed to
#' [setup_scenarios()] and as subsequently been passed to this function as a
#' long data frame rather than a wide data frame.
#'
#' @author Kelli F. Johnson
#' @export
#' @return An augmented data frame is returned in the same form as the
#' input data. The new rows correspond to parsing input arguments out
#' across all fleets that are sampled when a single input value is provided.
setup_scenarios_fleet <- function(data) {
#### Set up
# Create a FULL data set with missing values by
# expanding and nesting arg and fleet for sampling args
# Use lookup to see if they are from the beginning section
potentiallabels <- setup_scenarios_lookup()
fleetspecificlabels <- names(potentiallabels)[
1:which(potentiallabels == "wtatage_params")
]
beginlabel <- gsub("(.{2})\\..+", "\\1", data[["label"]])
if (all(is.na(data$arg))) {
return(data)
}
if (all(is.na(match(beginlabel, fleetspecificlabels)))) {
return(data)
}
# Remove fleets that have an NA, which means they weren't sampled
removedfleets <- data %>%
dplyr::filter(is.na(.data[["value"]])) %>%
dplyr::pull(.data[["fleet"]])
data <- data %>% dplyr::filter(!.data[["fleet"]] %in% removedfleets)
#### Make data
# Create a full data set providing one argument for each fleet
fleet <- NULL # To remove "no visible binding for global variable 'fleet'"
newdata <- dplyr::full_join(
by = c("arg", "fleet"),
data,
tidyr::expand(
data,
.data[["arg"]],
# see https://github.com/tidyverse/tidyr/issues/971 for why .data[["fleet"]] can't be used
tidyr::nesting(fleet)
) %>%
# Remove the rows that aren't fleet-specific
tidyr::drop_na(.data[["fleet"]])
) %>%
# Arrange and group so fill up works
dplyr::arrange(.data[["arg"]], .data[["fleet"]]) %>%
dplyr::group_by(.data[["arg"]]) %>%
tidyr::fill(.data[["value"]], .direction = "up") %>%
dplyr::ungroup() %>%
tidyr::drop_na(.data[["fleet"]])
# If no new data then return the old data
if (NROW(newdata) == 0) {
return(data)
} else {
# Make the full data set to return, including new fleet variable
return(
dplyr::nest_join(
by = colnames(newdata),
newdata,
data
) %>%
dplyr::select(-.data[["data"]]) %>%
dplyr::full_join(
by = c("label", "arg", "value"),
tibble::tibble(
label = paste(beginlabel[1], "fleets", sep = "."),
arg = "fleets",
value = list(utils::type.convert(
as.is = TRUE,
data %>% tidyr::drop_na(.data[["fleet"]]) %>%
dplyr::distinct(.data[["fleet"]]) %>% dplyr::pull(.data[["fleet"]])
))
)
)
)
}
}
#' Get scenario information from a data frame of specifications
#'
#' @param df A data frame with scenarios in the rows and
#' information for function arguments in the columns.
#' See [setup_scenarios_defaults] for how to set up the data frame.
#' This data frame is used by default if you do not supply anything
#' to `df`.
#' @param returntype The class of object that you want to return.
#' ss3sim was a big fan of lists of lists until the `tidyverse` packages
#' were included. Now, data frames of list columns are preferred.
#' Eventually, `list` will be downgraded from the default and data frames
#' will be the only option as a return.
#'
#' @author Kelli F. Johnson
#' @export
#' @return Either a long data frame or a list is returned.
#' See the input argument `returntype` for more information.
#' @examples
#' defaultscenarios <- setup_scenarios()
setup_scenarios <- function(df = "default",
returntype = c("list", "dataframe")) {
returntype <- match.arg(returntype)
if (is.character(df) && df == "default") {
df <- setup_scenarios_defaults()
}
if (all(!grepl("^om_*", names(df)))) {
df[["om_dir"]] <- setup_om_dir()
}
if (all(!grepl("^em_*", names(df)))) {
df[["em_dir"]] <- setup_em_dir()
}
scenarios <- df %>%
# Use rownames to track scenarios
tibble::rownames_to_column() %>%
# evaluate all arguments, e.g., '1:4' to 1,2,3,4
dplyr::mutate(dplyr::across(
dplyr::everything(),
~ purrr::map(.x, text2obj)
)) %>%
# wide to long by scenario
tidyr::pivot_longer(
!.data[["rowname"]],
names_to = "label",
values_to = "value"
) %>%
# change NULL to -999 b/c NULL has a zero length
# dplyr::mutate(
# value = map(value, ~replace_x(.x, -999))
# ) %>%
# Split name into columns
tidyr::separate(
col = .data[["label"]],
into = c("type", "arg", "fleet"),
sep = "\\.",
fill = "right",
remove = FALSE
) %>%
# Create one row per data type for each scenario
dplyr::group_by(.data[["rowname"]], .data[["type"]]) %>%
tidyr::nest() %>%
# Duplicate info by fleet
dplyr::mutate(data = purrr::map(.data[["data"]], setup_scenarios_fleet)) %>%
# Bring everything back together as a list of lists
tidyr::unnest(.data[["data"]]) %>%
dplyr::ungroup() %>%
tidyr::unite(
col = "label", .data[["type"]], .data[["arg"]], .data[["fleet"]],
sep = ".", na.rm = TRUE, remove = FALSE
) %>%
dplyr::mutate(type = purrr::map_chr(.data[["type"]], ~ setup_scenarios_lookup()[.x])) %>%
dplyr::arrange(.data[["type"]], .data[["arg"]], as.numeric(.data[["fleet"]]))
# check for NA or NULL values
labs_with_null_or_nas <- scenarios$label[unlist(lapply(
scenarios$value,
function(x) {
isTRUE(is.null(x)) |
isTRUE(any(is.na(x)))
}
))]
if (returntype == "dataframe") {
return(scenarios)
}
# Very convoluted way to make a list of lists b/c I am not familiar
# with dplyr and purrr, this is ugly and will eventually be removed
# after time to just use tibbles that can be more easily accessed.
if (returntype == "list") {
out <- scenarios %>%
dplyr::ungroup() %>%
dplyr::mutate(value = purrr::map(.data[["value"]], ~ replace_x(.x))) %>%
dplyr::mutate(value = stats::setNames(.data[["value"]], .data[["label"]])) %>%
dplyr::group_by(.data[["rowname"]], .data[["type"]]) %>%
tidyr::nest() %>%
dplyr::summarize(value = purrr::map(
.x = .data[["data"]], ~ {
xxx <- base::split(.x$value, .x$arg)
if (length(xxx) == 0) {
if (.x[["label"]] == "user_recdevs") {
return(.x[["value"]][[1]])
}
return(stats::setNames(unlist(.x$value), NULL))
}
if (!is.null(xxx[["fleets"]])) {
xxx[["fleets"]] <- stats::setNames(
stats::na.omit(unlist(xxx[["fleets"]])),
NULL
)
}
return(xxx)
}
)) %>%
dplyr::ungroup() %>%
dplyr::mutate(value = stats::setNames(.data[["value"]], .data[["type"]])) %>%
dplyr::select(-.data[["type"]]) %>%
dplyr::group_by(.data[["rowname"]]) %>%
tidyr::nest() %>%
dplyr::summarize(out = purrr::lmap(.data[["data"]], ~ do.call(as.list, .x)))
return(stats::setNames(out$out, out$rowname))
}
}
#' Create a named vector to look up full names for types of arguments
setup_scenarios_lookup <- function() {
lookuptable <- data.frame(
# This first section could have fleet specific parameters
# DO NOT change the first or the last, insert new ones between
# agecomp_params and wtatage_params, preferably in alphabetical order
c("sa", "agecomp_params"),
c("sc", "calcomp_params"),
c("sd", "discard_params"),
c("cf", "f_params"),
c("si", "index_params"),
c("sl", "lcomp_params"),
c("sm", "mlacomp_params"),
c("sw", "wtatage_params"),
# This is the second section that will not be fleet-specific
c("wc", "weight_comps_params"),
# todo(feature): weight the index
c("wi", "weight_index"),
c("em", "em_dir"),
c("om", "em_dir"),
c("em_dir", "em_dir"),
c("cb", "em_binning_params"),
c("cd", "data_params"),
c("ce", "estim_params"),
c("co", "operat_params"),
c("ct", "tv_params"),
c("cr", "retro_params"),
c("extras", "extras")
)
extraargs <- names(formals(ss3sim_base))
names(extraargs) <- extraargs
out <- lookuptable[2, ]
names(out) <- lookuptable[1, ]
out <- unlist(c(
out, extraargs[!extraargs %in% c(lookuptable[2, ], "...")]
))
return(out)
}
#' Set up a generic scenario
#'
#' Create a data frame of scenario inputs for a generic simulation that will
#' run within ss3sim. Users can add more arguments, but the scenario will run
#' without changing the returned value.
#'
#' @param nscenarios The number of rows you want returned in the data frame.
#' This argument removes the need for users to call [base::rbind()] repeatedly
#' on the output when you want to have more than one scenario.
#' All rows will be identical with the default settings.
#' The default is a single row.
#' @author Kelli F. Johnson
#' @export
#' @return A data frame with the minimal information needed to run a scenario.
#' The number of rows of the data frame depends on `nscenarios`.
#'
setup_scenarios_defaults <- function(nscenarios = 1) {
data.frame(
cf.years.1 = "26:100",
cf.fvals.1 = "rep(0.1052, 75)",
si.years.2 = "seq(62, 100, by = 2)",
si.sds_obs.2 = 0.1,
si.seas.2 = 1,
sl.Nsamp.1 = 50,
sl.years.1 = "26:100",
sl.Nsamp.2 = 100,
sl.years.2 = "seq(62, 100, by = 2)",
sl.cpar = "NULL",
sa.Nsamp.1 = 50,
sa.years.1 = "26:100",
sa.Nsamp.2 = 100,
sa.years.2 = "seq(62, 100, by = 2)",
sa.cpar = "NULL",
stringsAsFactors = FALSE
) %>%
dplyr::slice(rep(1:dplyr::n(), each = nscenarios))
}
#' Create a name for an unnamed scenario
#'
#' Create a name for an unnamed scenario based on [Sys.time].
#'
#' @param check A logical that enables checking for a unique name.
#' If `check = TRUE` then the function enters a loop and will generate
#' a names until it finds one that doesn't already exist.
#' This could be helpful when running scenarios in parallel.
#'
#' @return A single character value is returned.
#' The object starts with the letter `s` and is followed by [Sys.time]
#' Where, the date/time portion is `%m%d%H%M%S`, better known as
#' a two-digit month, e.g., 01; a two-digit number for the day of the month;
#' and finally a two-digit hour, then minute, then second.
#'
setup_scenarios_name <- function(check = FALSE) {
makename <- function() {
format(Sys.time(), "s%m%d%H%M%S")
}
dt <- makename()
if (check) {
while (file.exists(dt)) {
dt <- makename()
}
}
return(dt)
}
text2obj <- function(x) {
if (is.character(x)) {
tryCatch(eval(parse(text = x)), error = function(e) as.character(x))
} else {
x
}
}
setup_em_dir <- function() {
stats::setNames(
system.file("extdata", "models", "cod-em",
package = "ss3sim"
),
"em_dir"
)
}
setup_om_dir <- function() {
stats::setNames(
system.file("extdata", "models", "cod-om",
package = "ss3sim"
),
"om_dir"
)
}