R/simulation.R

In lbartnik/repository: Object Repository for R

#' Work with a sample artifact repository.
#'
#' @description Obtain a handle to a read/write copy of an artifact
#' repository installed with the package.
#'
#' @return a [repository] object.
#'
#' @name samples
#' @rdname samples
NULL

#' @details `iris_model` shows a simple modeling excercise with the
#' [datasets::iris] data set.
#'
#' @export
#' @rdname samples
iris_model <- function () {
  source_path <- system.file('iris-model/', package = 'repository')
  rw_copy(source_path)
}

#' @details `london_meters` documents a simple analysis of a subset of
#' the __London meters__ data; see the
#' [Kaggle website](https://www.kaggle.com/jeanmidev/smart-meters-in-london)
#' for more details on this data set.
#'
#' @export
#' @rdname samples
london_meters <- function () {
  source_path <- system.file('london-meters/', package = 'repository')
  rw_copy(source_path)
}

#' @details `execute_simulation` runs a script inside a simulated R
#' session with a artifact tracker enabled. Artifacts are stored in
#' repository `repo`.
#'
#' @param path path to a script to be executed.
#' @param repo store artifacts in this repository.
#'
#' @export
#' @rdname samples
execute_simulation <- function (path, repo) {
  stopifnot(file.exists(path))
  stopifnot(is_repository(repo))

  run_simulation(path, repo, FALSE)

  invisible(TRUE)
}


rw_copy <- function (source_path) {
  target_path <- file.path(tempdir(TRUE), basename(source_path))

  if (!dir.exists(target_path)) {
    dir.create(dirname(target_path), recursive = TRUE, showWarnings = FALSE)
    file.copy(source_path, dirname(target_path), recursive = TRUE)
  }

  repository(storage::filesystem(target_path, create = FALSE))
}



simulate_iris <- function (repo, .silent = TRUE) {
  run_simulation(system.file('scripts/iris-model.R', package = 'repository'), repo, .silent)
}

simulate_london_meters <- function (repo, .silent = TRUE) {
  run_simulation(system.file('scripts/london-meters.R', package = 'repository'), repo, .silent)
}

#' @importFrom rlang parse_exprs
run_simulation <- function (script_path, repo, .silent) {
  workspace <- session_simulator(repo, .silent = .silent)
  exprs <- parse_exprs(file(script_path))

  lapply(exprs, function (expr) {
    workspace$run_quoted(expr)
    simulation_meta_offset_time(60)
  })

  invisible(NULL)
}




# --- simulation & meta API --------------------------------------------

#' @import proto
#' @importFrom grDevices dev.off recordPlot
#' @importFrom utils capture.output
#' @importFrom rlang inform
#'
session_simulator <- function (repo, .silent = TRUE) {

  try(dev.off(), silent = TRUE)
  parent_env <- parent.frame(1)

  g <- proto(expr = {
    repo = NULL
    silent = TRUE
    session = new.env(parent = parent_env)
  })

  g$repo <- repo
  g$silent <- .silent

  g$inform <- function (., msg) {
    if (isFALSE(.silent)) rlang::inform(msg)
  }

  g$contents <- function (.) {
    as.list(.$session)
  }

  g$run <- function (., expr) {
    expr <- substitute(expr)
    .$run_quoted(expr)
  }

  g$run_quoted <- function (., expr) {
    if (is_meta_command(expr)) {
      .$inform(glue("meta command: {first(deparse(expr))}"))

      # replace function name and add `repo` and `env` arguments
      expr[[1]] <- as.symbol(extract_meta_command(expr))
      expr$repo <- .$repo
      expr$env  <- .$session

      eval(expr)
    } else {
      .$inform(glue("evaluating: {first(deparse(expr))}"))

      # print is necessary for graphics, but we don't want to see the
      # output on the console, thus - print and capture at the same time
      eval_expr <- substitute(print(expr), list(expr = expr))

      if (isTRUE(.silent)) {
        capture.output(eval(eval_expr, .$session, enclos = baseenv()))
      } else {
        eval(eval_expr, .$session, enclos = baseenv())
      }

      plot <- tryCatch(recordPlot(), error = function(e)'error')
      if (identical(plot, 'error')) plot <- NULL

      repository_update(repo, .$session, plot, expr)
    }
  }

  g
}

is_meta_command <- function (expr) {
  if (!is.call(expr)) return(FALSE)

  fun_spec <- first(expr)
  is.call(fun_spec) && identical(length(fun_spec), 3L) &&
    identical(first(fun_spec), quote(`::`)) && identical(second(fun_spec), quote(meta))
}

extract_meta_command <- function (expr) {
  paste0('simulation_meta_', as.character(nth(first(expr), 3)))
}


simulation_meta_state <- new.env()

simulation_meta_set <- function (name, value, ...) {
  assign(name, value, envir = simulation_meta_state)
}

simulation_meta_get <- function (name, ...) {
  get(name, envir = simulation_meta_state)
}

simulation_meta_unset <- function (names, ...) {
  rm(list = names, envir = simulation_meta_state)
}

#' @importFrom rlang quos quo_get_expr as_character
simulation_remember_object <- function (repo, env, ...) {
  args <- quos(...)
  stopifnot(identical(length(args), 1L))

  args <- quo_get_expr(first(args))
  stopifnot(is.symbol(args))

  name <- as_character(args)
  stopifnot(exists(name, envir = env), name %in% names(repo$last_commit$objects))

  simulation_meta_state$objects[[name]] <<- nth(repo$last_commit$objects, name)
}

simulation_meta_offset_time <- function (value, ...) {
  time <- simulation_meta_get('time')
  if (!is.null(time)) {
    value <- value + time
  }
  simulation_meta_set('time', value)
}