Allow advertising of globals

R/environment.R

@@ -17,6 +17,14 @@
 ##'   for some reason, just call `library` yourself within one of your
 ##'   `source` files.
 ##'
+##' @param globals Names of global objects that we can assume exist
+##'   within this environment.  This might include function
+##'   definitions or large data objects.  The special value `TRUE`
+##'   triggers automatic detection of objects within your environment
+##'   (this takes a few seconds and requires that the environment is
+##'   constructable on your local machine too, so is not currently
+##'   enabled by default).
+##'
 ##' @param overwrite On environment creation, replace an environment
 ##'   with the same name.
 ##'
@@ -27,12 +35,13 @@
 ##'
 ##' @rdname hipercow_environment
 ##' @export
-hipercow_environment_create <- function(name = "default", sources = NULL,
-                                      packages = NULL, overwrite = TRUE,
-                                      root = NULL) {
+hipercow_environment_create <- function(name = "default", packages = NULL,
+                                        sources = NULL, globals = NULL,
+                                        overwrite = TRUE, root = NULL) {
   root <- hipercow_root(root)
 
-  ret <- new_environment(name, sources, packages, root, rlang::current_env())
+  ret <- new_environment(name, packages, sources, globals,
+                         root, rlang::current_env())
 
   ## I did wonder about doing this by saving environment as:
   ##   hipercow/environments/values/<hash>
@@ -46,6 +55,8 @@ hipercow_environment_create <- function(name = "default", sources = NULL,
   ## look at this later, but literally noone wants it!
   path <- file.path(root$path$environments, name)
   exists <- file.exists(path)
+  prev <- if (exists) readRDS(path) else NULL
+
   if (exists && identical(readRDS(path), ret)) {
     cli::cli_alert_info("Environment '{name}' is unchanged")
   } else if (exists && !overwrite) {
@@ -110,14 +121,20 @@ print.hipercow_environment <- function(x, ...) {
     srcs <- cli::cli_vec(x$sources, list("vec-last" = ", "))
     cli::cli_li("sources: {.strong {srcs}}")
   }
+  if (length(x$globals) == 0) {
+    cli::cli_li("globals: {.emph (none)}")
+  } else {
+    srcs <- cli::cli_vec(x$globals, list("vec-last" = ", "))
+    cli::cli_li("globals: {.strong {srcs}}")
+  }
   invisible(x)
 }
 
 
 environment_load <- function(name, root, call = NULL) {
   path <- ensure_environment_exists(name, root, call)
   if (is.null(path)) {
-   new_environment(name, NULL, NULL, root)
+   new_environment(name, NULL, NULL, NULL, root)
   } else {
     readRDS(path)
   }
@@ -140,8 +157,12 @@ ensure_environment_exists <- function(name, root, call) {
 }
 
 
-new_environment <- function(name, sources, packages, root, call = NULL) {
+new_environment <- function(name, packages, sources, globals, root,
+                            call = NULL) {
   assert_scalar_character(name)
+  if (!is.null(packages)) {
+    assert_character(packages)
+  }
   if (!is.null(sources)) {
     assert_character(sources)
     err <- !file.exists(file.path(root$path$root, sources))
@@ -152,19 +173,28 @@ new_environment <- function(name, sources, packages, root, call = NULL) {
         call = call)
     }
   }
-  if (!is.null(packages)) {
-    assert_character(packages)
+  if (!is.null(globals)) {
+    if (isTRUE(globals)) {
+      globals <- discover_globals(name, packages, sources, root)
+    } else {
+      assert_character(globals)
+    }
   }
   ret <- list(name = name,
+              packages = packages,
               sources = sources,
-              packages = packages)
+              globals = globals)
   class(ret) <- "hipercow_environment"
   ret
 }
 
 
 environment_apply <- function(name, envir, root, call = NULL) {
-  env <- environment_load(name, root, call)
+  if (is.list(name)) {
+    env <- name
+  } else {
+    env <- environment_load(name, root, call)
+  }
   for (p in env$packages) {
     library(p, character.only = TRUE)
   }
@@ -175,3 +205,19 @@ environment_apply <- function(name, envir, root, call = NULL) {
     }
   }
 }
+
+
+discover_globals <- function(name, packages, sources, root) {
+  cli::cli_alert_info(
+    "Creating '{name}' in a clean R session; this may take a moment")
+  res <- callr::r(function(name, packages, sources, path_root) {
+    envir <- new.env(parent = topenv())
+    root <- hipercow_root(path_root)
+    env <- new_environment(name, packages, sources, NULL, root)
+    environment_apply(env, envir, root)
+    names(envir)
+  }, list(name, packages, sources, root$path$root), package = TRUE)
+  n <- length(res)
+  cli::cli_alert_success("Found {n} {cli::qty(n)}symbol{?s}")
+  res
+}

tests/testthat/test-environment.R

@@ -1,21 +1,24 @@
 test_that("can construct an environment", {
-  env <- new_environment("foo", NULL, NULL)
+  env <- new_environment("foo", NULL, NULL, NULL)
   expect_s3_class(env, "hipercow_environment")
-  expect_setequal(names(env), c("name", "packages", "sources"))
+  expect_setequal(names(env), c("name", "packages", "sources", "globals"))
   expect_equal(env$name, "foo")
   expect_null(env$packages)
   expect_null(env$sources)
+  expect_null(env$globals)
 })
 
 
 test_that("can construct a nontrivial environment", {
   path <- withr::local_tempfile()
   root <- init_quietly(path)
   file.create(file.path(path, c("a.R", "b.R")))
-  env <- new_environment("foo", c("a.R", "b.R"), c("x", "y", "z"), root)
+  env <- new_environment("foo", c("x", "y", "z"), c("a.R", "b.R"),
+                         c("i", "j", "k"), root)
   expect_equal(env$name, "foo")
   expect_equal(env$sources, c("a.R", "b.R"))
   expect_equal(env$packages, c("x", "y", "z"))
+  expect_equal(env$globals, c("i", "j", "k"))
 })
 
 
@@ -31,6 +34,7 @@ test_that("can print empty environments", {
   expect_match(msg, "hipercow environment 'default'", all = FALSE)
   expect_match(msg, "packages: (none)", all = FALSE, fixed = TRUE)
   expect_match(msg, "sources: (none)", all = FALSE, fixed = TRUE)
+  expect_match(msg, "globals: (none)", all = FALSE, fixed = TRUE)
 })
 
 
@@ -42,12 +46,14 @@ test_that("can print nontrivial environments", {
     hipercow_environment_create("foo",
                               packages = c("x", "y", "z"),
                               sources = c("a.R", "b.R", "c.R"),
+                              globals = c("i", "j", "k"),
                               root = path))
   msg <- capture_messages(
     hipercow_environment_show("foo", root))
   expect_match(msg, "hipercow environment 'foo'", all = FALSE)
   expect_match(msg, "packages: x, y, z", all = FALSE, fixed = TRUE)
   expect_match(msg, "sources: a.R, b.R, c.R", all = FALSE, fixed = TRUE)
+  expect_match(msg, "globals: i, j, k", all = FALSE, fixed = TRUE)
 })
 
 
@@ -69,7 +75,7 @@ test_that("can create environment in root", {
     hipercow_environment_create(packages = pkgs, root = path),
     "Created environment 'default'")
   expect_equal(environment_load("default", root),
-               new_environment("default", NULL, pkgs, root))
+               new_environment("default", pkgs, NULL, NULL, root))
 })
 
 
@@ -84,17 +90,17 @@ test_that("can update existing environment in root", {
     hipercow_environment_create(name = "foo", packages = pkgs1, root = path),
     "Created environment 'foo'")
   expect_equal(environment_load("foo", root),
-               new_environment("foo", NULL, pkgs1, root))
+               new_environment("foo", pkgs1, NULL, NULL, root))
   expect_message(
     hipercow_environment_create(name = "foo", packages = pkgs2, root = path),
     "Updated environment 'foo'")
   expect_equal(environment_load("foo", root),
-               new_environment("foo", NULL, pkgs2, root))
+               new_environment("foo", pkgs2, NULL, NULL, root))
   expect_message(
     hipercow_environment_create(name = "foo", packages = pkgs2, root = path),
     "Environment 'foo' is unchanged")
   expect_equal(environment_load("foo", root),
-               new_environment("foo", NULL, pkgs2, root))
+               new_environment("foo", pkgs2, NULL, NULL, root))
   expect_true(hipercow_environment_exists("foo", path))
   expect_equal(hipercow_environment_list(path), c("default", "foo"))
 })
@@ -110,7 +116,7 @@ test_that("can prevent overwriting of an environment", {
                               overwrite = FALSE, root = path),
     "Created environment 'foo'")
   expect_equal(environment_load("foo", root),
-               new_environment("foo", NULL, pkgs1, root))
+               new_environment("foo", pkgs1, NULL, NULL, root))
   expect_error(
     hipercow_environment_create(name = "foo", packages = pkgs2,
                               overwrite = FALSE, root = path),
@@ -123,7 +129,7 @@ test_that("creating initial default does not count as overwriting", {
   root <- init_quietly(path)
   pkgs <- c("x", "y")
   expect_equal(environment_load("default", root),
-               new_environment("default", NULL, NULL, root))
+               new_environment("default", NULL, NULL, NULL, root))
   expect_message(
     hipercow_environment_create(name = "default", packages = pkgs,
                               overwrite = FALSE, root = path),
@@ -217,3 +223,26 @@ test_that("can delete environments", {
     "Deleting environment 'foo' (if it existed)", fixed = TRUE)
   expect_equal(hipercow_environment_list(path), "default")
 })
+
+
+test_that("can discover globals in environment", {
+  path <- withr::local_tempfile()
+  root <- init_quietly(path)
+  writeLines(c("a <- 1", "b <- 2"), file.path(path, "src.R"))
+  res <- evaluate_promise(
+    discover_globals("myenv", NULL, "src.R", root))
+  expect_equal(res$result, c("a", "b"))
+  expect_match(res$messages[[1]], "Creating 'myenv' in a clean R session")
+  expect_match(res$messages[[2]], "Found 2 symbols")
+})
+
+
+test_that("special value 'TRUE' triggers global environment build", {
+  path <- withr::local_tempfile()
+  root <- init_quietly(path)
+  writeLines("a <- 1", file.path(path, "src.R"))
+  res <- evaluate_promise(new_environment("default", NULL, "src.R", TRUE, root))
+  expect_equal(res$result$globals, "a")
+  expect_match(res$messages[[1]], "Creating 'default' in a clean R session")
+  expect_match(res$messages[[2]], "Found 1 symbol\\b")
+})

tests/testthat/test-interface.R

@@ -144,7 +144,7 @@ test_that("can call provision", {
 
   hipercow_provision(root = path_here, show_log = FALSE)
   mockery::expect_called(mock_provision, 1)
-  environment <- new_environment("default", NULL, NULL)
+  environment <- new_environment("default", NULL, NULL, NULL)
   expect_equal(
     mockery::mock_args(mock_provision)[[1]],
     list(NULL, config, path_root, environment, show_log = FALSE))