Implement local_reproducible_output()

Part of #129

NAMESPACE

@@ -20,6 +20,7 @@ export(is.message)
 export(is.recordedplot)
 export(is.source)
 export(is.warning)
+export(local_reproducible_output)
 export(new_output_handler)
 export(parse_all)
 export(remove_hooks)

R/reproducible-output.R

@@ -0,0 +1,100 @@
+#' Control common output options
+#' 
+#' @description
+#' Often when using `evaluate()` you are running R code with a specific output
+#' context in mind. But there are many options and env vars that packages 
+#' will take from the current environment, meaning that output depends on
+#' the current state in undesirable ways. 
+#' 
+#' This function allows you to describe the characteristics of the desired
+#' output and takes care of setting the options and environment variables
+#' for you.
+#' 
+#' @export
+#' @param width Value of the `"width"` option.
+#' @param color Determines whether or not cli/crayon colour should be used.
+#' @param unicode Should we use unicode characaters where possible?
+#' @param hyperlinks Should we use ANSI hyperlinks?
+#' @param rstudio Should we pretend that we're running inside of RStudio?
+local_reproducible_output <- function(width = 80,
+                                      color = FALSE,
+                                      unicode = FALSE,
+                                      hyperlinks = FALSE,
+                                      rstudio = FALSE,
+                                      frame = parent.frame()) {
+
+  local_options(
+    # crayon
+    crayon.enabled = color,
+
+    # cli
+    cli.width = width,
+    cli.num_colors = if (color) 8L else 1L,    
+    cli.hyperlink = hyperlinks,
+    cli.hyperlink_run = hyperlinks,
+    cli.hyperlink_help = hyperlinks,
+    cli.hyperlink_vignette = hyperlinks,
+    cli.unicode = unicode,
+    cli.dynamic = FALSE,
+
+    # base R
+    width = width, 
+    useFancyQuotes = FALSE,
+    rlang_interactive = FALSE,
+
+    .frame = frame
+  )
+
+  local_envvar(
+    NO_COLOR = if (color) NA else 1,
+
+    # Simulate RStudio
+    RSTUDIO = if (rstudio) 1 else NA,
+    RSTUDIO_SESSION_PID = if (rstudio) Sys.getpid() else NA,
+    RSTUDIO_CHILD_PROCESS_PANE = if (rstudio) "build" else NA,
+    RSTUDIO_CLI_HYPERLINKS = if (rstudio) 1 else NA,
+    RSTUDIO_CONSOLE_WIDTH = width,
+    .frame = frame
+  )
+
+  local_collate("C", frame = frame)
+
+  invisible()
+}
+
+local_options <- function(..., .frame = parent.frame()) {
+  old <- options(...)
+  defer(options(old), .frame)
+
+  invisible()
+}
+
+local_envvar <- function(..., .frame = parent.frame()) {
+  old <- set_envvar(list(...))
+  defer(set_envvar(old), .frame)
+
+  invisible()
+}
+
+local_collate <- function(locale, frame = parent.frame()) {
+  old <- Sys.getlocale("LC_COLLATE")
+  defer(Sys.setlocale("LC_COLLATE", old), frame)
+  Sys.setlocale("LC_COLLATE", locale)
+
+  invisible()
+}
+
+# adapted from withr:::set_envvar
+set_envvar <- function(envs) {
+  if (length(envs) == 0) {
+    return()
+  }
+
+  old <- Sys.getenv(names(envs), names = TRUE, unset = NA)
+  set <- !is.na(envs)
+
+  if (any(set)) do.call("Sys.setenv", as.list(envs[set]))
+  if (any(!set)) Sys.unsetenv(names(envs)[!set])
+
+  invisible(old)
+}

tests/testthat/test-reproducible-output.R

@@ -0,0 +1,48 @@
+test_that("local_reproducible_output() respects local context", {
+
+  local_reproducible_output(width = 105)
+  expect_equal(getOption("width"), 105) 
+
+  local({ 
+    local_reproducible_output(width = 110)
+    expect_equal(getOption("width"), 110)
+  })
+
+  expect_equal(getOption("width"), 105) 
+})
+
+test_that("local_envvar respects local context", {
+  local_envvar(test = "a")
+  expect_equal(Sys.getenv("test"), "a")
+
+  local({
+    local_envvar(test = "b")
+    expect_equal(Sys.getenv("test"), "b")
+  })
+
+  expect_equal(Sys.getenv("test"), "a")
+  local({
+    local_envvar(test = NA)
+    expect_equal(Sys.getenv("test"), "")
+  })
+
+  expect_equal(Sys.getenv("test"), "a")
+})
+
+test_that("local_collate respects local context", {
+  if (Sys.info()[["sysname"]] == "Windows") {
+    locale <- l10n_info()$codeset
+  } else {
+    locale <- "en_US"
+  }
+
+  local_collate("C")
+  expect_equal(Sys.getlocale("LC_COLLATE"), "C")
+
+  local({
+    local_collate(locale)
+    expect_equal(Sys.getlocale("LC_COLLATE"), locale)
+  })
+
+  expect_equal(Sys.getlocale("LC_COLLATE"), "C")
+})