Use our own RNG stream

Closes #50.

R/colors.R

@@ -2,6 +2,7 @@
 #' @importFrom grDevices colors
 
 initialize_colors <- function(debug_pkgs) {
+  local_seed()
 
   cols <- c("green", "blue", "magenta", "cyan", "white", "yellow", "red",
             "silver")
@@ -26,3 +27,42 @@ get_package_style <- function(pkg) {
     identity
   }
 }
+
+local_seed <- function(.local_envir = parent.frame()) {
+  old_seed <- get_seed()
+  set_seed(debug_data$seed)
+  defer({
+    debug_data$seed <- get_seed()
+    set_seed(old_seed)
+  }, envir = .local_envir)
+}
+
+has_seed <- function() {
+  exists(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)
+}
+
+get_seed <- function() {
+  if (has_seed()) {
+    get(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)
+  }
+}
+
+set_seed <- function(seed) {
+  if (is.null(seed)) {
+    if (exists(
+      ".Random.seed",
+      globalenv(),
+      mode = "integer",
+      inherits = FALSE)) {
+      rm(".Random.seed", envir = globalenv())
+    }
+
+  } else {
+    assign(".Random.seed", seed, globalenv())
+  }
+}
+
+f <- function() {
+  local_seed()
+  sample(1:5)
+}

R/compat-defer.R

@@ -0,0 +1,79 @@
+# nocov start --- compat-defer --- 2020-06-16
+
+# This drop-in file implements withr::defer(). Please find the most
+# recent version in withr's repository.
+
+
+defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { }
+
+local({
+
+defer <<- defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) {
+  priority <- match.arg(priority)
+  if (identical(envir, .GlobalEnv) && is.null(get_handlers(envir))) {
+    message(
+      "Setting deferred event(s) on global environment.\n",
+      "  * Execute (and clear) with `withr::deferred_run()`.\n",
+      "  * Clear (without executing) with `withr::deferred_clear()`."
+    )
+  }
+  invisible(
+    add_handler(
+      envir,
+      handler = list(expr = substitute(expr), envir = parent.frame()),
+      front = priority == "first"
+    )
+  )
+}
+
+get_handlers <- function(envir) {
+  attr(envir, "handlers")
+}
+
+set_handlers <- function(envir, handlers) {
+  has_handlers <- "handlers" %in% names(attributes(envir))
+  attr(envir, "handlers") <- handlers
+  if (!has_handlers) {
+    call <- make_call(execute_handlers, envir)
+
+    # We have to use do.call here instead of eval because of the way on.exit
+    # determines its evaluation context
+    # (https://stat.ethz.ch/pipermail/r-devel/2013-November/067867.html)
+    do.call(base::on.exit, list(call, TRUE), envir = envir)
+  }
+}
+
+execute_handlers <- function(envir) {
+  handlers <- get_handlers(envir)
+  errors <- list()
+  for (handler in handlers) {
+    tryCatch(eval(handler$expr, handler$envir),
+      error = function(e) {
+        errors[[length(errors) + 1]] <<- e
+      }
+    )
+  }
+
+  for (error in errors) {
+    stop(error)
+  }
+}
+
+add_handler <- function(envir, handler, front) {
+  if (front) {
+    handlers <- c(list(handler), get_handlers(envir))
+  } else {
+    handlers <- c(get_handlers(envir), list(handler))
+  }
+
+  set_handlers(envir, handlers)
+  handler
+}
+
+make_call <- function(...) {
+  as.call(list(...))
+}
+
+}) # defer() namespace
+
+# nocov end