generated from epiverse-trace/packagetemplate
-
Notifications
You must be signed in to change notification settings - Fork 1
/
helper_functions.R
359 lines (337 loc) · 10.5 KB
/
helper_functions.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
#' Get scenario information
#'
#' @description Gets the value of one or more object in the `parameters` or the
#' extra information list `extra_info`.
#' @param x A `scenario` object.
#' @param which Which parameters to print.
#'
#' @return A named list with two elements, 'parameters' and 'extra_info', which
#' are themselves lists. Each of these lists has named elements corresponding to
#' the names passed in `which`. These are separated into two lists to make it
#' easier to identify whether they are model function arguments or extra
#' information for the scenario.
#' @export
#'
#' @examples
#' # create a scenario
#' scenario_pandemic_flu <- scenario(
#' model_function = "finalsize::final_size",
#' parameters = make_parameters_finalsize_UK(),
#' replicates = 1
#' )
#'
#' # get all parameters
#' sce_get_information(scenario_pandemic_flu)
#'
#' # get only some parameters
#' sce_get_information(scenario_pandemic_flu, which = c("r0", "solver"))
sce_get_information <- function(x, which) {
# check input
stopifnot(
"Input 'x' must be a `scenario` object" =
is_scenario(x)
)
# print/return chosen parameters as list
if (missing(which)) {
list(
model_parameters = x$parameters,
scenario_information = x$extra_info
)
} else {
info_list <- c(
x$parameters[which],
x$extra_info[which]
)
info_list <- Filter(function(x) !is.null(x), info_list)
if (length(info_list) == 0L) {
stop(
glue::glue(
"
'{which}' not found among scenario model parameters or extra \\
information
"
)
)
} else {
info_list
}
}
}
#' Add extra information to a scenario
#'
#' @param x A `scenario` object.
#' @param info A named list of information to be added to the `extra_info` list
#' of the scenario object `x`.
#'
#' @return The scenario `x` with the extra information added.
#' @export
#'
#' @examples
#' # get some parameters for a `finalsize` run
#' parameters <- make_parameters_finalsize_UK(r0 = 1.5)
#' extra_info <- list(
#' age_groups = rownames(parameters$contact_matrix)
#' )
#' x <- scenario(
#' model_function = "finalsize::final_size",
#' parameters = parameters
#' )
#'
#' sce_add_info(x, extra_info)
#'
sce_add_info <- function(x, info) {
# check input
stopifnot(
"Input 'x' must be a `scenario` object" =
is_scenario(x),
"Input 'info' must be a list with unique names" =
checkmate::test_list(info, any.missing = FALSE, names = "unique"),
# check for names already present in extra info
"Some input list elements in 'info' are already present in this scenario" =
(!any(names(info) %in% names(x$extra_info)))
)
# add data
x$extra_info <- c(x$extra_info, info)
# validate scenario and return
validate_scenario(x)
x
}
#' Check for scenario data
#'
#' @param x A `scenario` or `comparison` object.
#' @return Whether the `scenario` has data, or whether all `scenario` objects in
#' a `comparison` object have data generated.
#' @export
#' @examples
#' # create a scenario
#' pandemic_flu <- scenario(
#' name = "pandemic_flu",
#' model_function = "finalsize::final_size",
#' parameters = make_parameters_finalsize_UK(),
#' replicates = 1
#' )
#' covid19 <- scenario(
#' model_function = "finalsize::final_size",
#' parameters = make_parameters_finalsize_UK(r0 = 3.0),
#' replicates = 1
#' )
#'
#' # for a `scenario` object
#' sce_has_data(pandemic_flu)
#'
#' # for a `comparison` object
#' comparison_flu_covid <- comparison(
#' pandemic_flu, covid19,
#' baseline = "pandemic_flu"
#' )
#' sce_has_data(comparison_flu_covid)
sce_has_data <- function(x) {
UseMethod("sce_has_data", x)
}
#' Check for scenario data
#'
#' @param x A `scenario` object.
#'
#' @return A boolean, whether the simulation object has data.
#' @method sce_has_data scenario
#' @export
sce_has_data.scenario <- function(x) {
# check input
checkmate::assert_class(x, "scenario")
!all(vapply(x$data, is.null, FUN.VALUE = TRUE))
}
#' Check for scenario data
#'
#' @param x A `comparison` object.
#'
#' @method sce_has_data comparison
#' @export
#' @return A boolean, whether the simulation object has data.
sce_has_data.comparison <- function(x) {
# check input
checkmate::assert_class(x, "comparison")
all(vapply(x$data, sce_has_data.scenario, FUN.VALUE = TRUE))
}
#' Get scenario outcome names
#'
#' Function to quickly view the names and types of columns in the `scenario`
#' outcome data. Operates on the first replicate of each scenario run, and
#' assumes that the outcome data are data.frames.
#'
#' @param x A scenario object with data prepared. Check for whether data has
#' been prepared using [sce_has_data()].
#' @param view_rows Whether to return the first few rows of the first replicate
#' outcome, using [head()].
#'
#' @return Prints the scenario outcome data's column names and types to screen,
#' or the [head()] of the first outcome replicate if `view_rows = TRUE`.
#' @export
#'
#' @examples
#' # create a scenario
#' scenario_pandemic_flu <- scenario(
#' model_function = "finalsize::final_size",
#' parameters = make_parameters_finalsize_UK(),
#' replicates = 1
#' )
#' scenario_pandemic_flu <- run_scenario(scenario_pandemic_flu)
#'
#' # for column names and types
#' sce_peek_outcomes(scenario_pandemic_flu)
#' # for data.frame head
#' sce_peek_outcomes(scenario_pandemic_flu, view_rows = FALSE)
sce_peek_outcomes <- function(x, view_rows = FALSE) {
# check input
checkmate::assert_class(x, "scenario")
stopifnot(
"Scenario data are not prepared, run `run_scenario()` to prepare data." =
sce_has_data(x)
)
checkmate::assert_data_frame(data.table::first(x$data))
if (view_rows) {
utils::head(data.table::first(x$data))
} else {
vapply(data.table::first(x$data), class, FUN.VALUE = "numeric")
}
}
#' Aggregate scenario outcomes across replicates
#'
#' @description Function to aggregate outcomes from the replicate data of a
#' `scenario` object. The use case of this function is to provide a compact
#' representation of the model output, especially that of stochastic models.
#' @param x A scenario object with data prepared.
#' @param grouping_variables The variables that should be used to group the
#' outcomes of interest. Examples include demographic and susceptibility groups.
#' @param measure_variables The outcomes of interest which are summarised over
#' scenario replicates, and by all variables in the `grouping_variables`.
#' Examples include `p_infected` from the output of [finalsize::final_size()].
#' @param summary_functions The summary function names to apply to the measure
#' variables, passed as strings, i.e., "mean" rather than simply `mean`.
#'
#' @return A data.table with the outcomes of interest (measure variables)
#' summarised using the summary functions, by each grouping variable.
#' @export
#'
#' @examples
#' # create a scenario
#' scenario_pandemic_flu <- scenario(
#' model_function = "finalsize::final_size",
#' parameters = make_parameters_finalsize_UK(),
#' replicates = 3 # note extra replicates
#' )
#'
#' # run scenario
#' scenario_pandemic_flu <- run_scenario(scenario_pandemic_flu)
#'
#' # peek at outcome to see column names
#' sce_peek_outcomes(scenario_pandemic_flu)
#'
#' # aggregate outcome by demographic group
#' sce_aggregate_outcomes(
#' x = scenario_pandemic_flu,
#' grouping_variables = c("demo_grp"),
#' measure_variables = c("p_infected"),
#' summary_functions = c("mean", "min", "max")
#' )
sce_aggregate_outcomes <- function(x, grouping_variables, measure_variables,
summary_functions = c("mean", "sd")) {
# check input
checkmate::assert_class(x, "scenario")
checkmate::assert_character(grouping_variables, min.len = 1)
checkmate::assert_character(measure_variables, min.len = 1)
stopifnot(
"Scenario data are not prepared, run `run_scenario()` to prepare data." =
sce_has_data(x)
)
# prepare cast formula
formula <- eval(
paste(
# grouping variables reduced to: var1 + var2 + ...
Reduce(
f = function(x1, x2) paste(x1, x2, sep = " + "),
x = grouping_variables
),
# a tilde
" ~ ."
)
)
# return aggregated data.table
dt <- data.table::dcast(
data = sce_get_outcomes(x),
formula = formula,
value.var = measure_variables,
fun.aggregate = lapply(summary_functions, as.symbol)
)
# fix malformed names from dcast
if (length(measure_variables) == 1 && length(summary_functions) == 1) {
# fix names when only a single column is cast
data.table::setnames(dt, ".", glue::glue(
"{measure_variables}_{summary_functions}"
))
}
# return data.table
dt
}
#' Drop outcome data from a `scenario` or `comparison` object
#'
#' @param x A `scenario` or `comparison` object.
#'
#' @export
#' @return A `scenario` or `comparison` object where the `data` field is, for
#' `scenario` objects, an empty list of the same length as the number of
#' scenario replicates, and for `comparison` objects, a list of `scenario`
#' objects with the data removed.
#' @examples
#' pandemic_flu <- scenario(
#' model_function = "finalsize::final_size",
#' parameters = make_parameters_finalsize_UK(r0 = 1.5),
#' extra_info = list(country = "UK", pathogen = "flu")
#' )
#'
#' # run scenarios to generate data
#' pandemic_flu <- run_scenario(pandemic_flu)
#'
#' # drop data
#' sce_drop_data(pandemic_flu)
sce_drop_data <- function(x) {
UseMethod("sce_drop_data", x)
}
#' Drop outcome data from a `scenario` object
#'
#' @param x A `scenario` object.
#'
#' @method sce_drop_data scenario
#' @export
#' @return A `scenario` object where the `data` field is an empty list of the
#' same length as the number of scenario replicates.
sce_drop_data.scenario <- function(x) {
# check input
checkmate::assert_class(x, "scenario")
stopifnot(
"`scenario` does not have data prepared" =
sce_has_data(x)
)
# make data an empty list, validate, and return
x$data <- vector("list", length = x$replicates)
validate_scenario(x)
x
}
#' Drop outcome data from a `comparison` object
#'
#' @param x A `comparison` object.
#'
#' @method sce_drop_data comparison
#' @export
#' @return A `comparison` object where the `data` field is populated with
#' `scenario` objects from which the outcome data, if originally present,
#' has been dropped.
sce_drop_data.comparison <- function(x) {
# check input
checkmate::assert_class(x, "comparison")
# do not check for data present in comparison object,
# as there may be a mix of scenario objects with and without data
# make data an empty list, validate, and return
x$data <- lapply(x$data, sce_drop_data)
validate_comparison(x)
x
}