R/batch_simulation.R

In simlandr: Simulation-Based Landscape Construction for Dynamical Systems

#' 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)
}