Nothing
#' Create and modify argument sets, then make an argument grid
#' for batch simulation
#'
#' An argument set contains the descriptions of the relevant variables in a
#' batch simulation. Use `new_arg_set()` to create an `arg_set`
#' object, and use `add_arg_ele()` to add an element to the `arg_set`. After
#' adding all elements in the argument set, use `make_arg_grid()` to make an
#' argument grid that can be used directly for running batch simulation.
#'
#' @param arg_set An `arg_set` object.
#' @param arg_name,ele_name The name of the argument and its element
#' in the simulation function
#' @param start,end,by The data points where you want to test the variables.
#' Passed to `seq`.
#'
#' @return `new_arg_set()` returns an `arg_set` object.
#'
#' @seealso [batch_simulation()] for running batch simulation and a
#' concrete example.
#' @name arg_set-class
NULL
#' @describeIn arg_set-class Create an `arg_set`.
#' @export
new_arg_set <- function() {
result <- list()
class(result) <- c("arg_set", "list")
attr(result, "nele") <- 0
attr(result, "narg") <- 0
return(result)
}
#' @describeIn arg_set-class Add an element to an `arg_set`.
#' @return `add_arg_ele()` returns an `arg_set` object.
#' @export
add_arg_ele <- function(arg_set, arg_name, ele_name, start, end, by) {
arg_set[[arg_name]][[ele_name]] <- tibble::lst(start, end, by)
attr(arg_set, "nele") <- attr(arg_set, "nele") + 1
attr(arg_set, "narg") <- length(arg_set)
return(arg_set)
}
#' @describeIn arg_set-class The number of elements in an `arg_set`.
#' @param arg_set An `arg_set` object.
#' @return `nele()` returns an integer.
#' @export
nele <- function(arg_set) attr(arg_set, "nele")
#' @describeIn arg_set-class The number of arguments in an `arg_set`.
#' @param arg_set An `arg_set` object.
#' @return `narg()` returns an integer.
#' @export
narg <- function(arg_set) attr(arg_set, "narg")
#' @describeIn arg_set-class Print an `arg_set` object.
#'
#' @param x An `arg_set` object
#' @param detail Do you want to print the object details as a full list?
#' @param ... Not in use.
#' @method print arg_set
#' @export
print.arg_set <- function(x, detail = FALSE, ...) {
if (detail) {
print.default(x)
} else {
cat(
sprintf("An `arg_set` with %d argument(s) and %d element(s)", narg(x), nele(x))
)
}
}
#' Fill a vector of values into a structure list.
#'
#' @param vec A vector of values.
#' @param struct A list with a certain structure.
#'
#' @return A `ele_list` object.
#' @seealso [modified_simulation()]
#'
#' @export
#' @keywords internal
fill_in_struct <- function(vec, struct) {
if ("var_set" %in% class(struct)) {
lifecycle::deprecate_warn("0.2.0", "fill_in_struct(struct = 'should be an `arg_set`')")
} else if (!("arg_set" %in% class(struct))) stop("Wrong input class. `struct` should be an `arg_set`.")
vec_index <- 1
for (i in 1:length(struct)) {
for (j in 1:length(struct[[i]])) {
struct[[i]][[j]] <- vec[vec_index]
vec_index <- vec_index + 1
}
}
class(struct) <- c("ele_list", "list")
return(struct)
}
#' @describeIn arg_set-class Make an argument grid from an argument set.
#' @return `make_arg_gird()` returns an `arg_grid` object.
#' @export
make_arg_grid <- function(arg_set) {
ele_seq <- list()
arg_name <- list()
for (i in names(arg_set)) {
for (j in names(arg_set[[i]])) {
ele_seq[[j]] <- seq(arg_set[[i]][[j]]$start, arg_set[[i]][[j]]$end, arg_set[[i]][[j]]$by)
arg_name[[j]] <- names(arg_set)[i]
}
}
arg_grid_num <- expand.grid(ele_seq)
arg_grid_list <- data.frame(ele_list = rep(NA, nrow(arg_grid_num)))
arg_grid_list$ele_list <- apply(arg_grid_num, 1, fill_in_struct, arg_set)
arg_grid <- cbind(arg_grid_list, as.data.frame(arg_grid_num))
result <- arg_grid
class(result) <- c("arg_grid", "data.frame")
attr(result, "ele_seq") <- ele_seq
attr(result, "arg_name") <- arg_name
attr(result, "nele") <- nele(arg_set)
attr(result, "narg") <- narg(arg_set)
return(result)
}
#' @describeIn arg_set-class Print an `arg_grid` object
#'
#' @method print arg_grid
#' @export
print.arg_grid <- function(x, detail = FALSE, ...) {
if (detail) print.default(x)
cat(
sprintf(
"An `arg_grid` with %d argument(s), %d element(s), and %d condition(s)",
narg(x), nele(x), length(x$ele_list)
)
)
}
#' Modify a single simulation
#' @param ele_list An `ele_list` object generated by [fill_in_struct()].
#' @export
#' @keywords internal
modified_simulation <- function(sim_fun, ele_list, default_list, bigmemory = TRUE, ...) {
ddd <- list(...)
if ("var_list" %in% names(ddd)) {
lifecycle::deprecate_warn("0.2.0", "modified_simulation(var_list)", "modified_simulation(ele_list)")
ele_list <- ddd$var_list
ddd$var_list <- NULL
}
if ("var_grid" %in% names(ddd)) {
ddd$var_grid <- NULL
}
sim_fun_list <- default_list
for (i in names(ele_list)) {
for (j in names(ele_list[[i]])) {
sim_fun_list[[i]][[j]] <- ele_list[[i]][[j]]
}
}
result <- do.call(sim_fun, append(sim_fun_list, values = ddd))
if (bigmemory & is.matrix(result)) result <- as_hash_big_matrix(result)
return(result)
}
#' Perform a batch simulation.
#'
#' @param arg_grid An `arg_grid` object. See [make_arg_grid()].
#' @param sim_fun The simulation function. See [sim_fun_test()]
#' for an example.
#' @param default_list A list of default values for `sim_fun`.
#' @param bigmemory Use [hash_big_matrix-class()] to store large matrices?
#' @param ... Other parameters passed to `sim_fun`
#'
#' @return A `batch_simulation` object, also a data frame.
#' The first column, `var`, is a list of
#' `ele_list` that contains all the variables; the second to the second
#' last columns are the values of the variables; the last column is the
#' output of the simulation function.
#'
#' @describeIn batch_simulation Perform a batch simulation.
#'
#' @examples
#' batch_arg_set_grad <- new_arg_set()
#' batch_arg_set_grad <- batch_arg_set_grad %>%
#' add_arg_ele(
#' arg_name = "parameter", ele_name = "a",
#' start = -6, end = -1, by = 1
#' )
#' batch_grid_grad <- make_arg_grid(batch_arg_set_grad)
#' batch_output_grad <- batch_simulation(batch_grid_grad, sim_fun_grad,
#' default_list = list(
#' initial = list(x = 0, y = 0),
#' parameter = list(a = -4, b = 0, c = 0, sigmasq = 1)
#' ),
#' length = 1e2,
#' seed = 1614,
#' bigmemory = FALSE
#' )
#' print(batch_output_grad)
#' @export
batch_simulation <- function(arg_grid, sim_fun, default_list, bigmemory = TRUE, ...) {
ddd <- list(...)
if ("var_list" %in% names(ddd)) {
lifecycle::deprecate_warn("0.2.0", "modified_simulation(var_grid)", "modified_simulation(arg_grid)")
arg_grid <- ddd$var_grid
arg_grid$ele_list <- arg_grid$var_list
} else if (!"ele_list" %in% names(arg_grid)) {
arg_grid$ele_list <- arg_grid$var_list
}
result <- arg_grid %>%
dplyr::mutate(output = purrr::map(ele_list, function(x) modified_simulation(sim_fun = sim_fun, ele_list = x, default_list = default_list, bigmemory = bigmemory, ...)))
class(result) <- c("batch_simulation", "data.frame")
attr(result, "sim_fun") <- sim_fun
return(result)
}
#' @rdname batch_simulation
#' @method print batch_simulation
#' @inheritParams print.arg_set
#' @export
print.batch_simulation <- function(x, detail = FALSE, ...) {
if (detail) {
print.default(x)
} else {
cat(
sprintf("Output(s) from %d simulations.", nrow(x))
)
}
}
#' Attach all matrices in a batch simulation
#'
#' @param bs A `batch_simulation` object.
#' @param backingpath Passed to [bigmemory::as.big.matrix()].
#'
#' @return A `batch_simulation` object with all `hash_big_matrix`es attached.
#' @export
attach_all_matrices <- function(bs, backingpath = "bp") {
if (!"batch_simulation" %in% class(bs)) stop("Wrong input class. bs should be a `batch_simulation`.")
bs <- bs %>%
dplyr::mutate(output = purrr::map(output, attach_hash_big_matrix, backingpath = backingpath))
return(bs)
}
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.