R/experiment-methods.R

In choisy/gamar3: Interface to the Agent-Based Modeling Platform GAMA

#' @export
as.list.experiment <- function(x, ...) {
  map <- map_par(x)
  slots <- unique(map$section)
  x$.attrs <- list(x$.attrs)  # to comply with the map_par output structure
  map <- split(map, map$section)[slots]
  out <- lapply(map, reformat)
  lapply(out, function(z) sapply(z, function(y) x[[y]]))
}


#' @export
`c.experiment` <- function(...) {
  args <- list(...)
  sel <- sapply(args, function(x) "plan" %in% class(x))
  if (any(sel)) {
    for(i in which(sel)) args[i] <- unclass(args[i])
    if (any(!sel)) for(i in which(!sel)) args[i] <- list(args[i])
    args <- unlist(args, recursive = FALSE)
  }
  if (length(unique(sapply(args, "[", "sourcePath"))) > 1)
    stop("The experiments do not all call the same model.")
  for(i in seq_along(args)) args[[i]]$.attrs["id"] <- i
  rename(args)
}


#' @export
duration.experiment <- function(x) {
  unname(as.integer(as.list(x)$.attrs["finalStep"]))
}


#' @export
`duration<-.experiment` <- function(x, value) {
  x$.attrs["finalStep"] <- as.character(value)
  x
}


#' @export
fname.experiment <- function(x) {
  unname(x["sourcePath"])
}


#' @export
`fname<-.experiment` <- function(x, value) {
  if (substring(value, 1, 1) != "/") value <- paste0(getwd(), "/", value)
  x["sourcePath"] <- value
  x
}


#' @importFrom utils file.edit
#' @export
model.experiment <- function(x) {
  file.edit(fname(x))
}


#' @export
monper.experiment <- function(x) {
  as_integer(as.list(x)$Outputs)
}


#' @export
`monper<-.experiment` <- function(x, value) {
  value <- as.character(value)
  n <- length(monper(x))
  l <- length(value)
  get_ind <- function() {
    tmp <- map_par(x)
    sel <- unlist(subset(tmp, section == "Outputs", param))
    reformat(tmp)[sel]
  }
  if (l == 1) {
    for (i in get_ind()) x[[i]] <- value
    return(x)
  } else if (n == l) {
    for(i in 1:n) x[[get_ind()[[i]]]] <- value[i]
    return(x)
  } else stop(paste("The length of the vector should be 1 or", n))
}


#' @export
names.experiment <- function(x) {
  map_par(x)$param
}


#' @export
parameters.experiment <- function(x) {
  as_numeric(as.list(x)$Parameters)
}


#' @export
`parameters<-.experiment` <- function(x, value) {
  value <- as.character(value)
  n <- length(parameters(x))
#  l <- length(value)
  if (n == length(value)) {
    tmp <- map_par(x)
    sel <- unlist(subset(tmp, section == "Parameters", param))
    ind <- reformat(tmp)[sel]
    for(i in 1:n) x[[ind[[i]]]] <- value[i]
    return(x)
  } else stop(paste("The length of the vector should be", n))
}


#' @export
print.experiment <- function(x, ...) {
  exp2 <- as.list(x)
  cat("An experiment of the model defined in:\n")
  cat(paste0(exp2$.attrs["sourcePath"], "\n"))
  cat("\nParameters values:\n")
  print(as_numeric(exp2$Parameters))
  cat(paste("\nNumber of steps in the simulation:", exp2$.attrs["finalStep"]))
  cat("\n\nPeriods (in steps) at which variables are monitored:\n")
  print(as_numeric(exp2$Outputs))
  cat(paste("\nSeed value:", exp2$.attrs["seed"]))
  invisible(x)
}


#' @export
rep.experiment <- function(x, ...) {
  plan <- rename(rep(list(x), ...))
  for(i in seq_along(plan)) plan[[i]]$.attrs["id"] <- i
  plan
}


#' @export
run.experiment <- function(x, hpc = 1, output) {
  files <- startexperimentplan(list(x), hpc, output)
  lapply(files, readxmlfile)
}


#' @export
seed.experiment <- function(x) {
  unname(as.integer(as.list(x)$.attrs["seed"]))
}


#' @export
`seed<-.experiment` <- function(x, value) {
  x$.attrs["seed"] <- as.character(value)
  x
}


#' @export
simulparms.experiment <- function(x) {
  exp2 <- as.list(x)
  cat(paste("Number of steps in the simulation:", exp2$.attrs["finalStep"]))
  cat("\n\nPeriods (in steps) at which variables are monitored:\n")
  print(as_numeric(exp2$Outputs))
  cat(paste("\nSeed value:", exp2$.attrs["seed"]))
}


#' @export
variables.experiment <- function(x) {
  names(as.list(x)$Outputs)
}


#' @export
`[.experiment` <- function(x, values) {
  exp <- flatten(x)
  exp_names <- names(exp)
  if (all(values %in% exp_names)) {
    exp <- exp[values]
    if (!(any(c("experiment", "file") %in% exp_names))) exp <- as.numeric(exp)
  } else exp <- unclass(exp)[value]
  suppressWarnings(num <- as_numeric(exp))
  if (any(is.na(num))) return(exp) else return(num)
}


#' @export
`[<-.experiment` <- function(x, slot, value) {
  map <- map_par(x)
  x$.attrs <- list(x$.attrs)  # to comply with the map_par output structure
  map <- as.list(reformat(map)[slot])
  for(i in seq_along(value)) x[[map[[i]]]] <- value[i]
  x$.attrs <- unlist(x$.attrs, recursive = FALSE)  # back to initial structure
  x
}