globals/0000755000177700017770000000000013225441521013226 5ustar herbrandtherbrandtglobals/tests/0000755000177700017770000000000013220527536014376 5ustar herbrandtherbrandtglobals/tests/utils.R0000644000177700017770000000727413126232643015670 0ustar herbrandtherbrandtlibrary("globals") message("*** utils ...") as_function <- globals:::as_function find_base_pkgs <- globals:::find_base_pkgs is_base_pkg <- globals:::is_base_pkg is.base <- globals:::is.base is_internal <- globals:::is_internal where <- globals:::where mdebug <- globals:::mdebug ## WORKAROUND: Make sure tests also work with 'covr' package if ("covr" %in% loadedNamespaces()) { globalenv <- function() parent.frame() baseenv <- function() environment(base::sample) } message("* hpaste() ...") printf <- function(...) cat(sprintf(...)) hpaste <- globals:::hpaste # Some vectors x <- 1:6 y <- 10:1 z <- LETTERS[x] # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Abbreviation of output vector # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - printf("x = %s.\n", hpaste(x)) ## x = 1, 2, 3, ..., 6. printf("x = %s.\n", hpaste(x, max_head = 2)) ## x = 1, 2, ..., 6. printf("x = %s.\n", hpaste(x), max_head = 3) # Default ## x = 1, 2, 3, ..., 6. # It will never output 1, 2, 3, 4, ..., 6 printf("x = %s.\n", hpaste(x, max_head = 4)) ## x = 1, 2, 3, 4, 5 and 6. # Showing the tail printf("x = %s.\n", hpaste(x, max_head = 1, max_tail = 2)) ## x = 1, ..., 5, 6. # Turning off abbreviation printf("y = %s.\n", hpaste(y, max_head = Inf)) ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 ## ...or simply printf("y = %s.\n", paste(y, collapse = ", ")) ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 # Change last separator printf("x = %s.\n", hpaste(x, last_collapse = " and ")) ## x = 1, 2, 3, 4, 5 and 6. # No collapse stopifnot(all(hpaste(x, collapse = NULL) == x)) # Empty input stopifnot(identical(hpaste(character(0)), character(0))) message("* hpaste() ... DONE") message("* as_function() ...") fcn <- as_function({ 1 }) print(fcn()) stopifnot(fcn() == 1) message("* find_base_pkgs() & is_base_pkg() ...") base_pkgs <- find_base_pkgs() print(base_pkgs) stopifnot(length(base_pkgs) > 1L) for (pkg in base_pkgs) { stopifnot(is_base_pkg(pkg)) } stopifnot(!is_base_pkg("globals")) message("* is.base() & is_internal() ...") stopifnot(is.base(base::library)) stopifnot(!is.base(globals::globalsOf)) stopifnot(!is.base(NULL)) stopifnot(is_internal(print.default)) stopifnot(!is_internal(globals::globalsOf)) stopifnot(!is_internal(NULL)) message("* where() ...") env <- where("sample", where = 1L) str(env) env <- where("sample", frame = 1L) str(env) message("- where('sample') ...") env <- where("sample", mode = "function") print(env) if (!"covr" %in% loadedNamespaces()) { stopifnot(identical(env, baseenv())) } obj <- get("sample", mode = "function", envir = env, inherits = FALSE) stopifnot(identical(obj, base::sample)) message("- where('sample', mode = 'integer') ...") env <- where("sample", mode = "integer") print(env) stopifnot(is.null(env)) message("- where('sample2') ...") sample2 <- base::sample env <- where("sample2", mode = "function") print(env) stopifnot(identical(env, environment())) obj <- get("sample2", mode = "function", envir = env, inherits = FALSE) stopifnot(identical(obj, sample2)) message("- where() - local objects of functions ...") aa <- 1 foo <- function() { bb <- 2 #nolint list(aa = where("aa"), bb = where("bb"), cc = where("cc"), envir = environment()) } envs <- foo() str(envs) stopifnot(identical(envs$aa, globalenv())) stopifnot(identical(envs$bb, envs$envir)) stopifnot(is.null(envs$cc)) message("- where() - missing ...") env <- where("non-existing-object", inherits = FALSE) stopifnot(is.null(env)) rm(list = c("aa", "envs", "foo", "env", "obj", "where")) message("* where() ... DONE") message("- mdebug() ...") mdebug("Message A") oopts <- options(globals.debug = TRUE) mdebug("Message B") options(oopts) message("* mdebug() ... DONE") message("*** utils ... DONE") globals/tests/conservative.R0000644000177700017770000000423213075205110017217 0ustar herbrandtherbrandtlibrary("globals") ovars <- ls(envir = globalenv()) ## WORKAROUND: Avoid problem reported in testthat Issue #229, which ## causes covr::package_coverage() to given an error. /HB 2015-02-16 suppressWarnings({ rm(list = c("a", "b", "c", "x", "y", "z", "square", "pathname", "url", "filename")) }) message("Setting up expressions") exprs <- list( A = substitute({ Sys.sleep(1); x <- 0.1 }, env = list()), B = substitute({ y <- 0.2 }, env = list()), C = substitute({ z <- a + 0.3 }, env = list()), D = substitute({ pathname <- file.path(dirname(url), filename) }, env = list()), E = substitute({ b <- c }, env = list()), F = substitute({ a <- { runif(1) } b <- { rnorm(1) } x <- a * b; abs(x) }, env = list()), G = substitute({ y <- square(a) }, env = list()), H = substitute({ b <- a a <- 1 }, env = list()) ) atleast <- list( A = c(), B = c(), C = c("a"), D = c("filename"), E = c("c"), F = c(), G = c("a", "square"), H = c() ## FIXME: Should be c("a"), cf. Issue #5. ) not <- list( A = c("x"), B = c("y"), C = c("z"), D = c("pathname"), E = c("b"), F = c("a", "b", "x"), G = c(), H = c() ) ## Define globals a <- 3.14 c <- 2.71 square <- function(x) x ^ 2 filename <- "index.html" # Yes, pretend we forget 'url' message("Find globals") for (kk in seq_along(exprs)) { key <- names(exprs)[kk] expr <- exprs[[key]] cat(sprintf("Expression #%d ('%s'):\n", kk, key)) print(expr) names <- findGlobals(expr, method = "conservative") cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names)) stopifnot(!any(names %in% not[[key]])) globals <- globalsOf(expr, method = "conservative") cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names(globals))) stopifnot(!any(names(globals) %in% not[[key]])) str(globals) cat("\n") } names <- findGlobals(exprs, method = "conservative", unlist = TRUE) cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) ## Cleanup rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) globals/tests/liberal.R0000644000177700017770000000422113075205110016117 0ustar herbrandtherbrandtlibrary("globals") ovars <- ls(envir = globalenv()) ## WORKAROUND: Avoid problem reported in testthat Issue #229, which ## causes covr::package_coverage() to given an error. /HB 2015-02-16 suppressWarnings({ rm(list = c("a", "b", "c", "x", "y", "z", "square", "pathname", "url", "filename")) }) message("Setting up expressions") exprs <- list( A = substitute({ Sys.sleep(1); x <- 0.1 }, env = list()), B = substitute({ y <- 0.2 }, env = list()), C = substitute({ z <- a + 0.3 }, env = list()), D = substitute({ pathname <- file.path(dirname(url), filename) }, env = list()), E = substitute({ b <- c }, env = list()), F = substitute({ a <- { runif(1) } b <- { rnorm(1) } x <- a * b; abs(x) }, env = list()), G = substitute({ y <- square(a) }, env = list()), H = substitute({ b <- a a <- 1 }, env = list()) ) atleast <- list( A = c(), B = c(), C = c("a"), D = c("filename"), E = c("c"), F = c(), G = c("a", "square"), H = c() ## FIXME: Should be c("a"), cf. Issue #5. ) not <- list( A = c("x"), B = c("y"), C = c("z"), D = c("pathname"), E = c("b"), F = c(), G = c(), H = c() ) ## Define globals a <- 3.14 c <- 2.71 square <- function(x) x ^ 2 filename <- "index.html" # Yes, pretend we forget 'url' message("Find globals") for (kk in seq_along(exprs)) { key <- names(exprs)[kk] expr <- exprs[[key]] cat(sprintf("Expression #%d ('%s'):\n", kk, key)) print(expr) names <- findGlobals(expr, method = "liberal") cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names)) stopifnot(!any(names %in% not[[key]])) globals <- globalsOf(expr, method = "liberal", mustExist = FALSE) cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", "))) stopifnot(all(atleast[[key]] %in% names(globals))) stopifnot(!any(names(globals) %in% not[[key]])) str(globals) cat("\n") } names <- findGlobals(exprs, method = "liberal", unlist = TRUE) cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) ## Cleanup rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv()) globals/tests/dotdotdot.R0000644000177700017770000001341313075205110016514 0ustar herbrandtherbrandtlibrary("globals") opts <- options(warn = 1L) exprs <- list( ok = substitute(function(...) sum(x, ...)), warn = substitute(sum(x, ...)) ) message("*** findGlobals() ...") for (name in names(exprs)) { expr <- exprs[[name]] message("\n*** codetools::findGlobals():") fun <- globals:::as_function(expr) print(fun) globals <- codetools::findGlobals(fun) print(globals) stopifnot(all.equal(globals, c("sum", "x"))) message("\n*** findGlobals(dotdotdot = 'ignore'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- findGlobals(expr, dotdotdot = "ignore") print(globals) stopifnot(all.equal(globals, c("sum", "x"))) message("\n*** findGlobals(dotdotdot = 'return'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- findGlobals(expr, dotdotdot = "return") print(globals) if (name == "ok") { stopifnot(all.equal(globals, c("sum", "x"))) } else { stopifnot(all.equal(globals, c("sum", "x", "..."))) } message("\n*** findGlobals(dotdotdot = 'warn'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- findGlobals(expr, dotdotdot = "warn") print(globals) if (name == "ok") { stopifnot(all.equal(globals, c("sum", "x"))) } else { stopifnot(all.equal(globals, c("sum", "x", "..."))) } message("\n*** findGlobals(dotdotdot = 'error'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- try(findGlobals(expr, dotdotdot = "error")) if (name == "ok") { stopifnot(all.equal(globals, c("sum", "x"))) } else { stopifnot(inherits(globals, "try-error")) } } # for (name ...) message("\n*** findGlobals(, dotdotdot = 'return'):") print(exprs) globals <- findGlobals(exprs, dotdotdot = "return") print(globals) message("*** findGlobals() ... DONE") message("*** globalsOf() ...") x <- 1:2 for (name in names(exprs)) { expr <- exprs[[name]] message("\n*** globalsOf(dotdotdot = 'ignore'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "ignore") print(globals) stopifnot(all.equal(names(globals), c("sum", "x"))) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'return'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "return") print(globals) if (name == "ok") { stopifnot(all.equal(names(globals), c("sum", "x"))) } else { stopifnot(all.equal(names(globals), c("sum", "x", "..."))) stopifnot(!is.list(globals$`...`) && is.na(globals$`...`)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'warn'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "warn") print(globals) if (name == "ok") { stopifnot(all.equal(names(globals), c("sum", "x"))) } else { stopifnot(all.equal(names(globals), c("sum", "x", "..."))) stopifnot(!is.list(globals$`...`) && is.na(globals$`...`)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'error'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- try(globalsOf(expr, dotdotdot = "error")) if (name == "ok") { stopifnot(all.equal(names(globals), c("sum", "x"))) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) } else { stopifnot(inherits(globals, "try-error")) } } # for (name ...) message("\n*** globalsOf(, dotdotdot = 'return'):") print(exprs) globals <- globalsOf(exprs, dotdotdot = "return") print(globals) message("*** globalsOf() ... DONE") message("*** function(x, ...) globalsOf() ...") aux <- function(x, ..., exprs) { args <- list(...) for (name in names(exprs)) { expr <- exprs[[name]] message("\n*** globalsOf(dotdotdot = 'ignore'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "ignore") print(globals) stopifnot(all.equal(names(globals), c("sum", "x"))) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'return'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "return") print(globals) if (name == "ok") { stopifnot(all.equal(names(globals), c("sum", "x"))) } else { stopifnot(all.equal(names(globals), c("sum", "x", "..."))) stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'warn'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- globalsOf(expr, dotdotdot = "warn") print(globals) if (name == "ok") { stopifnot(all.equal(names(globals), c("sum", "x"))) } else { stopifnot(all.equal(names(globals), c("sum", "x", "..."))) stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE)) } stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) message("\n*** globalsOf(dotdotdot = 'error'):") cat(sprintf("Expression '%s':\n", name)) print(expr) globals <- try(globalsOf(expr, dotdotdot = "error")) if (name == "ok") { stopifnot(all.equal(names(globals), c("sum", "x"))) stopifnot(all.equal(globals$sum, base::sum)) stopifnot(all.equal(globals$x, x)) } else { stopifnot(inherits(globals, "try-error")) } } # for (name ...) message("\n*** globalsOf(, dotdotdot = 'return'):") print(exprs) globals <- globalsOf(exprs, dotdotdot = "return") print(globals) } # aux() aux(x = 3:4, y = 1, z = 42L, exprs = exprs) message("*** function(x, ...) globalsOf() ... DONE") ## Undo options(opts) globals/tests/walkAST.R0000644000177700017770000000602213217405106016021 0ustar herbrandtherbrandtlibrary("globals") message("*** walkAST() ...") exprs <- list( null = substitute(NULL), atomic = substitute(1), atomic = substitute("a"), atomic = substitute(TRUE), assign = substitute(a <- 1), assign = substitute(1 -> a), assign = substitute(a <- b + 1), assign = substitute(x <- rnorm(20, mu = 0)), index = substitute(x[1, 1]), index = substitute(x[1:2, 1:2]), index = substitute(x[, 1:2]), index = substitute(x[, 1]), fcn = substitute(function(a = 1, b = 2) sum(c(a, b))), fcn = substitute(function(a = 1, b) sum(c(a, b))), fcn = substitute(function(a = 1, b = 2, ...) sum(c(a, b, ...))), fcn = substitute(function(a = NULL) a), ok = substitute(function(...) sum(x, ...)), warn = substitute(sum(x, ...)), null = substitute(NULL), builtin = base::length, closure = function() NULL, closure = function() a, closure = function(x = 0) a * x, special = base::log, list = substitute(FUN(a = A), list(A = list())), pairlist = substitute(FUN(a = A), list(A = pairlist(a = 1))), expression = substitute(FUN(a = A), list(A = expression())) # environment = new.env() ) if (requireNamespace("methods")) { exprs$s4 <- methods::getClass("MethodDefinition") } nullify <- function(e) NULL disp <- function(expr) { cat("Expression:\n") print(expr) cat("str():\n") str(expr) cat(sprintf("typeof: %s\n", typeof(expr))) if (is.recursive(expr)) { cat("as.list():\n") str(as.list(expr)) } expr } ## disp() for (kk in seq_along(exprs)) { name <- names(exprs)[kk] message(sprintf("- walkAST() ...", kk, sQuote(name))) expr <- exprs[[kk]] disp(expr) ## Assert identity (default behavior) expr_i <- walkAST(expr) disp(expr_i) stopifnot(length(expr_i) == length(expr), identical(expr_i, expr)) ## Display the AST tree walkAST(expr, atomic = disp, name = disp, call = disp, pairlist = disp) ## Nullify expr_n <- walkAST(expr, atomic = nullify, name = nullify, call = nullify, pairlist = nullify) disp(expr_n) message("*** walkAST() - nullify ... DONE") message(sprintf("- walkAST() ... DONE", kk, sQuote(name))) } ## for (name ...) message("*** walkAST() - substitute = TRUE ...") expr <- walkAST(a <- 1, substitute = TRUE) print(expr) message("*** walkAST() - substitute = TRUE ... DONE") message("*** walkAST() - exceptions ...") f <- function(...) get("...") expr <- f(NULL) options(globals.walkAST.onUnknownType = "error") res <- tryCatch({ walkAST(expr) }, error = identity) print(res) stopifnot(inherits(res, "simpleError")) options(globals.walkAST.onUnknownType = "warning") foo <- walkAST(expr) res <- tryCatch({ walkAST(expr) }, warning = identity) print(res) stopifnot(inherits(res, "simpleWarning")) options(globals.walkAST.onUnknownType = "error") message("*** walkAST() - exceptions ... DONE") message("*** walkAST() ... DONE") globals/tests/Globals.R0000644000177700017770000001430113075205110016070 0ustar herbrandtherbrandtlibrary("globals") a <- 1 b <- 2 message("*** Globals() ...") globals0 <- globalsByName(c("a", "rnorm")) globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("a", "rnorm")), all(names(globals) == names(where)) ) message("*** Globals() - names ...") globals <- globals0 str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globals0))), all(names(globals) == names(where)) ) names(globals)[1] <- "A" str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("A", names(globals0)[-1])), all(names(globals) == names(where)) ) message("*** Globals() - names ... DONE") message("*** Globals() - subsetting ...") globals <- globals0[1] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 1L, length(where) == length(globals), all(names(globals) == c("a")), all(names(globals) == names(where)) ) globals <- globals0[2] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 1L, length(where) == length(globals), all(names(globals) == c("rnorm")), all(names(globals) == names(where)) ) globals <- globals0[2:1] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == c("rnorm", "a")), all(names(globals) == names(where)) ) ## rev() works automatically thanks to `[`() :) globals <- rev(globals0) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == rev(names(globals0))), all(names(globals) == names(where)), identical(rev(globals), globals0) ) message("*** Globals() - subsetting ... DONE") message("*** Globals() - subsetted assignment ...") globals <- globals0 globals$a <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals, globals0) ) globals <- globals0 globals$b <- globals0["a"] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 3L, length(where) == length(globals), all(names(globals) == c(names(globals0), "b")), all(names(globals) == names(where)), identical(globals$b, globals0$a) ) globals <- globals0 globals$a <- NULL str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 1L, length(where) == length(globals), all(names(globals) == names(globals0)[-1]), all(names(globals) == names(where)), is.null(globals$a) ) globals <- globals0 globals$a <- 1:2 str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)), identical(globals$a, 1:2) ) message("*** Globals() - subsetted assignment ... DONE") message("*** Globals() - combining ...") globals_a <- globals0[1:2] globals_b <- globals0[1:2] globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals_b <- list(b = 1, c = letters) globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals_b <- list() globals <- c(globals_a, globals_b) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globals_a), names(globals_b))), all(names(globals) == names(where)) ) globals_a <- globals0[1:2] globals <- c(globals_a, b = 1, c = letters) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globals_a), "b", "c")), all(names(globals) == names(where)) ) message("*** Globals() - combining ... DONE") message("*** Globals() - unique ...") globals <- globals0[c(1:2, 1:2, 1:2)] str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 6L, length(where) == length(globals), all(names(globals) == rep(names(globals0), times = 3L)), all(names(globals) == names(where)) ) globals <- unique(globals) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == length(globals0), length(where) == length(globals), all(names(globals) == names(globals0)), all(names(globals) == names(where)) ) message("*** Globals() - unique ... DONE") message("*** Globals() - coercion ...") globals <- as.Globals(globals0) stopifnot(identical(globals, globals0)) globals <- as.Globals(unclass(globals0)) stopifnot(identical(globals, globals0)) globals_t <- unclass(globals0) attr(globals_t, "where") <- NULL globals <- as.Globals(globals_t) stopifnot( length(globals) == length(globals0), names(globals) == names(globals0) ) message("*** Globals() - coercion ... DONE") message("*** Globals() - empty ...") globals <- Globals() globals <- Globals(list()) globals <- as.Globals(list()) message("*** Globals() - empty ... DONE") message("*** Globals() - exceptions ...") res <- tryCatch({ Globals(NULL) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(a = 1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) ## Assigning more than one element globals <- globals0 res <- tryCatch({ globals$a <- globals0[2:1] }, error = identity) stopifnot(inherits(res, "simpleError")) ## Appending unnamed objects res <- tryCatch({ c(globals0, 2) }, error = identity) stopifnot(inherits(res, "simpleError")) message("*** Globals() - exceptions ... DONE") message("*** Globals() ... DONE") globals/tests/globalsOf.R0000644000177700017770000002134513220527536016436 0ustar herbrandtherbrandtlibrary("globals") ## WORKAROUND: Make sure tests also work with 'covr' package covr <- ("covr" %in% loadedNamespaces()) if (covr) { globalenv <- function() parent.frame() baseenv <- function() environment(base::sample) } a <- 0 b <- 2 c <- 3 d <- NULL e <- function() TRUE expr <- substitute({ x <- b; b <- 1; y <- c; z <- d; a <- a + 1; e <- e() }, env = list()) message("*** findGlobals() ...") message(" ** findGlobals(..., method = 'conservative'):") globals_c <- findGlobals(expr, method = "conservative") print(globals_c) stopifnot(all(globals_c %in% c("{", "<-", "c", "d", "+"))) message(" ** findGlobals(..., method = 'liberal'):") globals_l <- findGlobals(expr, method = "liberal") print(globals_l) stopifnot(all(globals_l %in% c("{", "<-", "b", "c", "d", "+", "a", "e"))) message(" ** findGlobals(..., method = 'ordered'):") globals_i <- findGlobals(expr, method = "ordered") print(globals_i) stopifnot(all(globals_i %in% c("{", "<-", "b", "c", "d", "+", "a", "e"))) message(" ** findGlobals(..., tweak):") tweak_another_expression <- function(expr) { substitute({ x <- B; B <- 1; y <- C; z <- D }, env = list()) } globals_i <- findGlobals(expr, tweak = tweak_another_expression) stopifnot(all(globals_i %in% c("{", "<-", "B", "C", "D"))) message(" ** findGlobals(..., trace = TRUE):") globals_i <- findGlobals(expr, trace = TRUE) print(globals_i) stopifnot(all(globals_i %in% c("{", "<-", "b", "c", "d", "+", "a", "e"))) message("*** findGlobals() ... DONE") message("*** globalsByName() ...") globals_c <- globalsByName(c("{", "<-", "c", "d")) str(globals_c) stopifnot(all(names(globals_c) %in% c("{", "<-", "c", "d"))) globals_c <- cleanup(globals_c) str(globals_c) stopifnot(all(names(globals_c) %in% c("c", "d"))) where <- attr(globals_c, "where") stopifnot( length(where) == length(globals_c), identical(where$c, globalenv()), identical(where$d, globalenv()) ) foo <- globals::Globals globals <- globalsByName(c("{", "foo", "list"), recursive = FALSE) str(globals) stopifnot(all(names(globals) %in% c("{", "foo", "list"))) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`{`, baseenv()), identical(where$foo, globalenv()), identical(where$list, baseenv()) ) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("foo"))) globals <- cleanup(globals, drop = "internals") str(globals) stopifnot(all(names(globals) %in% c("foo"))) pkgs <- packagesOf(globals) stopifnot(pkgs == "globals") message("*** globalsByName() ... DONE") message("*** globalsOf() ...") message(" ** globalsOf(..., method = 'conservative'):") globals_c <- globalsOf(expr, method = "conservative") str(globals_c) stopifnot(all(names(globals_c) %in% c("{", "<-", "c", "d", "+"))) globals_c <- cleanup(globals_c) str(globals_c) stopifnot(all(names(globals_c) %in% c("c", "d"))) where <- attr(globals_c, "where") stopifnot( length(where) == length(globals_c), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf(..., method = 'liberal'):") globals_l <- globalsOf(expr, method = "liberal") str(globals_l) stopifnot(all(names(globals_l) %in% c("{", "<-", "b", "c", "d", "+", "a", "e"))) globals_l <- cleanup(globals_l) str(globals_l) stopifnot(all(names(globals_l) %in% c("b", "c", "d", "a", "e"))) where <- attr(globals_l, "where") stopifnot( length(where) == length(globals_l), identical(where$b, globalenv()), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf(..., method = 'ordered'):") globals_i <- globalsOf(expr, method = "ordered") str(globals_i) stopifnot(all(names(globals_i) %in% c("{", "<-", "b", "c", "d", "+", "a", "e"))) globals_i <- cleanup(globals_i) str(globals_i) stopifnot(all(names(globals_i) %in% c("b", "c", "d", "a", "e"))) where <- attr(globals_i, "where") stopifnot( length(where) == length(globals_i), identical(where$b, globalenv()), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf() w/ globals in local functions:") a <- 1 bar <- function(x) x - a foo <- function(x) bar(x) for (method in c("ordered", "conservative", "liberal")) { globals <- globalsOf({ foo(3) }, substitute = TRUE, method = method, recursive = FALSE, mustExist = FALSE) stopifnot(all(names(globals) %in% c("{", "foo")), !any("a" %in% names(globals))) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("foo"), !any("a" %in% names(globals)))) globals <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered", recursive = TRUE, mustExist = FALSE) stopifnot(all(names(globals) %in% c("{", "foo", "bar", "-", "a"))) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("foo", "bar", "a"))) globals <- globalsOf({ foo(3) }, substitute = TRUE, recursive = TRUE, mustExist = FALSE) stopifnot(all(names(globals) %in% c("{", "foo", "bar", "-", "a"))) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("foo", "bar", "a"))) } message(" ** globalsOf() w/ recursive functions:") ## "Easy" f <- function() Recall() globals <- globalsOf(f) str(globals) ## Direct recursive call f <- function() f() globals <- globalsOf(f) str(globals) ## Indirect recursive call f <- function() g() g <- function() f() globals_f <- globalsOf(f) str(globals_f) globals_g <- globalsOf(g) str(globals_g) globals_f <- globals_f[order(names(globals_f))] globals_g <- globals_g[order(names(globals_g))] stopifnot(identical(globals_g, globals_f)) message("*** globalsOf() ... DONE") message("*** Subsetting of Globals:") globals_l <- globalsOf(expr, method = "liberal") globals_s <- globals_l[-1] stopifnot(length(globals_s) == length(globals_l) - 1L) stopifnot(identical(class(globals_s), class(globals_l))) where_l <- attr(globals_l, "where") where_s <- attr(globals_s, "where") stopifnot(length(where_s) == length(where_l) - 1L) stopifnot(identical(where_s, where_l[-1])) message("*** cleanup() & packagesOf():") globals <- globalsOf(expr, method = "conservative") str(globals) stopifnot(all(names(globals) %in% c("{", "<-", "c", "d", "+"))) globals <- as.Globals(globals) str(globals) stopifnot(all(names(globals) %in% c("{", "<-", "c", "d", "+"))) globals <- as.Globals(unclass(globals)) str(globals) stopifnot(all(names(globals) %in% c("{", "<-", "c", "d", "+"))) pkgs <- packagesOf(globals) print(pkgs) stopifnot(length(pkgs) == 0L) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("c", "d"))) pkgs <- packagesOf(globals) print(pkgs) stopifnot(length(pkgs) == 0L) message("*** globalsOf() and package functions:") foo <- globals::Globals expr <- substitute({ foo(list(a = 1)) }) globals <- globalsOf(expr, recursive = FALSE) str(globals) stopifnot(all(names(globals) %in% c("{", "foo", "list"))) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`{`, baseenv()), identical(where$foo, globalenv()), identical(where$list, baseenv()) ) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("foo"))) pkgs <- packagesOf(globals) stopifnot(pkgs == "globals") message("*** globalsOf() and core-package functions:") sample2 <- base::sample sum2 <- base::sum expr <- substitute({ x <- sample(10) y <- sum(x) x2 <- sample2(10) y2 <- sum2(x) s <- sessionInfo() }, env = list()) globals <- globalsOf(expr, recursive = FALSE) str(globals) stopifnot(all(names(globals) %in% c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2"))) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot( identical(where$`<-`, baseenv()), identical(where$sample, baseenv()), identical(where$sample2, globalenv()) ) globals <- cleanup(globals) str(globals) stopifnot(all(names(globals) %in% c("sample2", "sum2"))) where <- attr(globals, "where") stopifnot(length(where) == length(globals)) if (!covr) stopifnot(identical(where$sample2, globalenv())) globals <- cleanup(globals, drop = "primitives") str(globals) stopifnot(all(names(globals) %in% c("sample2"))) message("*** globalsOf() - exceptions ...") rm(list = "a") res <- try({ globals <- globalsOf({ x <- a }, substitute = TRUE, mustExist = TRUE) }, silent = TRUE) stopifnot(inherits(res, "try-error")) message("*** globalsOf() - exceptions ... DONE") message("*** Globals() - exceptions ...") res <- tryCatch({ Globals(NULL) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) res <- tryCatch({ Globals(list(a = 1, 2)) }, error = identity) stopifnot(inherits(res, "simpleError")) message("*** Globals() - exceptions ... DONE") globals/tests/zzz.R0000644000177700017770000000003513071107411015342 0ustar herbrandtherbrandt## Just a dummy place holder globals/tests/formulas.R0000644000177700017770000000123113075205110016333 0ustar herbrandtherbrandtlibrary("globals") message("findGlobals() with formula ...") g <- findGlobals(. ~ x + y : z, substitute = TRUE) print(g) stopifnot(all(c("~", ".", "+", "x", ":", "y", "z") %in% g)) g <- findGlobals(map(1L, ~ typeof(.x)), substitute = TRUE) print(g) stopifnot(all(c("map", "~", "typeof", ".x") %in% g)) message("findGlobals() with formula ... DONE") message("globalsOf() with formula ...") foo <- function(x) { map(1L, ~ typeof(x + .x)) } g <- globalsOf(foo(1L), substitute = TRUE, mustExist = FALSE) str(g) stopifnot(all( c("foo", "map", "{", "~", "typeof", "+", "x", ".x") %in% names(g) )) message("globalsOf() with formula ... DONE") rm(list = "g") globals/NAMESPACE0000644000177700017770000000115613220103607014443 0ustar herbrandtherbrandt# Generated by roxygen2: do not edit by hand S3method("$<-",Globals) S3method("[",Globals) S3method("names<-",Globals) S3method(as.Globals,Globals) S3method(as.Globals,list) S3method(c,Globals) S3method(cleanup,Globals) S3method(packagesOf,Globals) S3method(unique,Globals) export(Globals) export(as.Globals) export(cleanup) export(findGlobals) export(globalsByName) export(globalsOf) export(packagesOf) export(walkAST) importFrom(codetools,findLocalsList) importFrom(codetools,makeUsageCollector) importFrom(codetools,walkCode) importFrom(utils,capture.output) importFrom(utils,installed.packages) importFrom(utils,str) globals/NEWS0000644000177700017770000001233413225320434013727 0ustar herbrandtherbrandtPackage: globals ================ Version: 0.11.0 [2018-01-09] NEW FEATURES: o Now findGlobals() identifies 'x' as a global variable in 'x <- x + 1' and likewise for x + 1 -> x. Note that ditto using `<<-` and `->>` was already identifying 'x' as a global. BUG FIXES: o findGlobals(..., trace = TRUE) now outputs only to standard error. Previously, some of the output went to standard output. Version: 0.10.3 [2017-10-12] BUG FIXES: o globalsOf(..., recursive = TRUE) would result in "Error in match.fun(FUN) : node stack overflow" if one of the globals identified was a function that called itself recursively (either directly or indirectly). Version: 0.10.2 [2017-08-08] BUG FIXES: o walkAST() could produce error "Cannot walk expression. Unknown object type '...'" for objects of type 'environment'. Version: 0.10.1 [2017-07-01] BUG FIXES: o walkAST() could produce error "Cannot walk expression. Unknown object type '...'" for objects of type 'list', 'expression' and 'S4'. Version: 0.10.0 [2017-04-16] NEW FEATURES: o Globals that are part of a formula are now identified. o findGlobals(..., trace = TRUE) will now show low-level parse information as the abstract syntax tree (AST) is walked. SOFTWARE QUALITY: o Enabled more internal sanity checks. BUG FIXES: o walkAST() could produce error "Cannot walk expression. Unknown object type 'nnn'" for expressions of type 'builtin', 'closure' and 'special'. Version: 0.9.0 [2017-03-09] NEW FEATURES: o Added option 'globals.debug', which when TRUE enables debugging output. BUG FIXES: o globalsOf(..., recursive = TRUE) would in some cases scan an incorrect subset of already identified globals. o globalsOf(..., recursive = TRUE) failed to skip objects part of package namespaces that where defined via a local() statement. Version: 0.8.0 [2017-01-14] NEW FEATURES: o globalsOf() identifies also globals in locally defined functions. This can be disabled with argument recursive = FALSE. o findGlobals() now takes both closures (functions) and expressions. Version: 0.7.2 [2016-12-28] BUG FIXES: o c(x, list()) where x is a Globals object would give an error reporting that the list does not have named elements. Version: 0.7.1 [2016-10-13] NEW FEATURES: o Globals() and as.Globals() now accepts an empty list as input as well. BUG FIXES: o walkAST(quote( function(x=NULL) 0 )) would give a sanity check error due to the NULL argument. Thank you GitHub user billy34 for reporting on this. Version: 0.7.0 [2016-09-08] NEW FEATURES: o Added walkAST(), which can be used to tweak expressions. o Added globalsByName() for locating and retrieving a set of known global variables. o Added c(), $<-(), names(), unique() for Globals objects. o Improved as.Globals() for lists. Version: 0.6.1 [2016-01-31] NEW FEATURES: o Now the error message of globalsOf(..., mustExist=TRUE) when it fails to locate a global also gives information on the expression that is problematic. BUG FIXES: o cleanup() for Globals did not cleanup functions in core package environments named 'package:'. Version: 0.6.0 [2015-12-12] NEW FEATURES: o findGlobals() is updated to handle the case where a local variable is overwriting a global one with the same name, e.g. { a <- b; b <- 1 }. Now 'b' is correctly identified as a global object. Previously it would have been missed. For backward compatibility, the previous behavior can be obtained using argument method="conservative". Version: 0.5.0 [2015-10-13] NEW FEATURES: o globalsOf() now returns attribute 'where' specifying where each global object is located. BUG FIXES: o cleanup() now only drops objects that are *located* in one of the "base" packages; previously it would also drop copies of such objects, e.g. FUN <- base::sample. Version: 0.4.1 [2015-10-05] BUG FIXES: o globalsOf() failed to return global variables with value NULL. They were identified but silently dropped. Version: 0.4.0 [2015-09-12] NEW FEATURES: o findGlobals() and globalsOf() gained argument 'dotdotdot'. Version: 0.3.1 [2015-06-10] o More test coverage. Version: 0.3.0 [2015-06-08] NEW FEATURES: o Renamed getGlobals() to globalsOf(). Version: 0.2.3 [2015-06-08] NEW FEATURES: o Added [() for Globals. o findGlobals() and getGlobals() gained argument 'substitute'. o Added cleanup(..., method="internals"). Version: 0.2.2 [2015-05-20] NEW FEATURES: o Added Globals class with methods cleanup() and packagesOf(). Added as.Globals() to coerce lists to Globals objects. Version: 0.2.1 [2015-05-20] NEW FEATURES: o getGlobals() gained argument 'mustExist' for controlling whether to give an error when the corresponding object for an identified global cannot be found or to silently drop the missing global. o findGlobals() and getGlobals() gained argument 'method' for controlling whether a "conservative" or a "liberal" algorithm for identifying true globals should be used. Version: 0.2.0 [2015-05-19] o Moved globals function from an in-house package to this package. Version: 0.1.0 [2015-02-07] o Created. globals/R/0000755000177700017770000000000013225226121013424 5ustar herbrandtherbrandtglobals/R/packagesOf.R0000644000177700017770000000161713075205110015615 0ustar herbrandtherbrandt#' @export packagesOf <- function(...) UseMethod("packagesOf") #' Identify the packages of the globals #' #' @param globals A Globals object. #' @param \dots Not used. #' #' @return Returns a character vector of package names. #' #' @aliases packagesOf #' @export packagesOf.Globals <- function(globals, ...) { ## Scan 'globals' for which packages needs to be loaded. ## This information is in the environment name of the objects. pkgs <- sapply(globals, FUN = function(obj) { environmentName(environment(obj)) }) ## Drop "missing" packages, e.g. globals in globalenv(). pkgs <- pkgs[nzchar(pkgs)] ## Drop global environment pkgs <- pkgs[pkgs != "R_GlobalEnv"] ## Keep only names matching loaded namespaces pkgs <- intersect(pkgs, loadedNamespaces()) ## Packages to be loaded pkgs <- sort(unique(pkgs)) ## Sanity check stopifnot(all(nzchar(pkgs))) pkgs } # packagesOf() globals/R/utils.R0000644000177700017770000000543413220544060014715 0ustar herbrandtherbrandtas_function <- function(expr, envir = parent.frame(), ...) { eval(substitute(function() x, list(x = expr)), envir = envir, ...) } #' @importFrom utils installed.packages find_base_pkgs <- local({ pkgs <- NULL function() { if (length(pkgs) > 0L) return(pkgs) data <- installed.packages() is_base <- (data[, "Priority"] %in% "base") pkgs <<- rownames(data)[is_base] pkgs } }) is_base_pkg <- function(pkgs) { pkgs <- gsub("^package:", "", pkgs) pkgs %in% find_base_pkgs() } # cf. is.primitive() is.base <- function(x) { if (typeof(x) != "closure") return(FALSE) is_base_pkg(environmentName(environment(x))) } # cf. is.primitive() is_internal <- function(x) { if (typeof(x) != "closure") return(FALSE) body <- deparse(body(x)) any(grepl(".Internal", body, fixed = TRUE)) } ## From R.utils 2.0.2 (2015-05-23) hpaste <- function(..., sep="", collapse=", ", last_collapse=NULL, max_head=if (missing(last_collapse)) 3 else Inf, max_tail=if (is.finite(max_head)) 1 else Inf, abbreviate="...") { max_head <- as.double(max_head) max_tail <- as.double(max_tail) if (is.null(last_collapse)) last_collapse <- collapse # Build vector 'x' x <- paste(..., sep = sep) n <- length(x) # Nothing todo? if (n == 0) return(x) if (is.null(collapse)) return(x) # Abbreviate? if (n > max_head + max_tail + 1) { head <- x[seq_len(max_head)] tail <- rev(rev(x)[seq_len(max_tail)]) x <- c(head, abbreviate, tail) n <- length(x) } if (!is.null(collapse) && n > 1) { if (last_collapse == collapse) { x <- paste(x, collapse = collapse) } else { x_head <- paste(x[1:(n - 1)], collapse = collapse) x <- paste(x_head, x[n], sep = last_collapse) } } x } ## From future 0.11.0 trim <- function(s) { sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s)) } # trim() ## From future 0.11.0 hexpr <- function(expr, trim = TRUE, collapse = "; ", max_head = 6L, max_tail = 3L, ...) { code <- deparse(expr) if (trim) code <- trim(code) hpaste(code, collapse = collapse, max_head = max_head, max_tail = max_tail, ...) } # hexpr() ## From future 1.3.0 mdebug <- function(...) { if (!getOption("globals.debug", FALSE)) return() message(sprintf(...)) } ## mdebug() #' @importFrom utils capture.output str mstr <- function(...) { bfr <- capture.output(str(...)) bfr <- paste(bfr, collapse = "\n") message(bfr, appendLF = TRUE) } #' @importFrom utils capture.output envname <- function(env) { name <- environmentName(env) if (name == "") { ## e.g. new.env() name <- capture.output(print(env)) name <- gsub("(.*: |>)", "", name) } else { ## e.g. globals:::where("plan") name <- gsub("package:", "", name, fixed = TRUE) } name } globals/R/cleanup.R0000644000177700017770000000237113075205110015177 0ustar herbrandtherbrandt#' @export cleanup <- function(...) UseMethod("cleanup") #' Drop certain types of globals #' #' @param globals A Globals object. #' @param drop A character vector specifying what type of globals to drop. #' @param \dots Not used #' #' @aliases cleanup #' @export cleanup.Globals <- function(globals, drop = c("missing", "base-packages"), ...) { where <- attr(globals, "where") names <- names(globals) keep <- rep(TRUE, times = length(globals)) names(keep) <- names ## Drop non-found objects if ("missing" %in% drop) { for (name in names) { if (is.null(where[[name]])) keep[name] <- FALSE } } ## Drop objects that are part of one of the "base" packages if ("base-packages" %in% drop) { for (name in names) { if (is_base_pkg(environmentName(where[[name]]))) keep[name] <- FALSE } } ## Drop objects that are primitive functions if ("primitives" %in% drop) { for (name in names) { if (is.primitive(globals[[name]])) keep[name] <- FALSE } } ## Drop objects that calls .Internal() if ("internals" %in% drop) { for (name in names) { if (is_internal(globals[[name]])) keep[name] <- FALSE } } if (!all(keep)) { globals <- globals[keep] } globals } globals/R/walkAST.R0000644000177700017770000000701213142351205015055 0ustar herbrandtherbrandt#' Walk the Abstract Syntax Tree (AST) of an R Expression #' #' @param expr R \link[base]{expression}. #' @param atomic,name,call,pairlist single-argument function that takes an #' atomic, name, call and pairlist expression, respectively. Have to #' return a valid R expression. #' @param name single-argument function that takes a name expression. #' @param call single-argument function that takes a call expression. #' @param pairlist single-argument function that takes a pairlist expression. #' @param substitute If TRUE, \code{expr} is #' \code{\link[base]{substitute}()}:ed. #' #' @return R \link[base]{expression}. #' #' @export #' @keywords programming internal walkAST <- function(expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL, substitute = FALSE) { if (substitute) expr <- substitute(expr) if (is.atomic(expr)) { if (is.function(atomic)) expr <- atomic(expr) } else if (is.name(expr)) { if (is.function(name)) expr <- name(expr) } else if (is.call(expr)) { ## message("call") for (cc in seq_along(expr)) { ## AD HOC: The following is needed to handle x[, 1]. /HB 2016-09-06 if (is.name(expr[[cc]]) && expr[[cc]] == "") next e <- walkAST(expr[[cc]], atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) if (is.null(e)) { expr[cc] <- list(NULL) } else { expr[[cc]] <- e } } if (is.function(call)) expr <- call(expr) } else if (is.pairlist(expr)) { ## message("pairlist") for (pp in seq_along(expr)) { ## AD HOC: The following is needed to handle '...'. /HB 2016-09-06 if (is.name(expr[[pp]]) && expr[[pp]] == "") next e <- walkAST(expr[[pp]], atomic = atomic, name = name, call = call, pairlist = pairlist, substitute = FALSE) if (is.null(e)) { expr[pp] <- list(NULL) } else { expr[[pp]] <- e } } ## WORKAROUND: Since expr[i] <- list(NULL) turns pairlist 'expr' into ## a list we have to make sure to it is a pairlist also afterward, cf. ## https://stat.ethz.ch/pipermail/r-devel/2016-October/073263.html ## /HB 2016-10-12 expr <- as.pairlist(expr) } else if (is.list(expr)) { ## FIXME: Should we have a specific function for this, or is atomic() ok? ## https://github.com/HenrikBengtsson/globals/issues/27 if (is.function(atomic)) expr <- atomic(expr) } else if (typeof(expr) %in% c("builtin", "closure", "special", "expression", "S4", "environment")) { ## Nothing to do ## FIXME: ... or can closures and specials be "walked"? /HB 2017-03-21 ## FIXME: Should "promise", "char", "...", "any", "externalptr", ## "bytecode", and "weakref" (cf. ?typeof) also be added? /2017-07-01 return(expr) } else { msg <- paste("Cannot walk expression. Unknown object type", sQuote(typeof(expr))) onUnknownType <- getOption("globals.walkAST.onUnknownType", "error") if (onUnknownType == "error") { stop(msg, call. = FALSE) } else if (onUnknownType == "warning") { warning(msg, call. = FALSE) } ## Skip below assertion return(expr) } ## Assert that the tweak functions return a valid object if (!missing(expr)) { stopifnot(is.atomic(expr) || is.list(expr) || is.name(expr) || is.call(expr) || is.pairlist(expr) || typeof(expr) %in% c("builtin", "closure", "special")) } expr } ## walkAST() globals/R/where.R0000644000177700017770000000334213170230111014654 0ustar herbrandtherbrandt## Emulates R internal findVar1mode() function ## https://svn.r-project.org/R/trunk/src/main/envir.c where <- function(x, where = -1, envir = if (missing(frame)) { if (where < 0) parent.frame(-where) else as.environment(where) } else sys.frame(frame), frame, mode = "any", inherits = TRUE) { ## Validate arguments stopifnot(is.environment(envir)) stopifnot(is.character(mode), length(mode) == 1L) inherits <- as.logical(inherits) stopifnot(inherits %in% c(FALSE, TRUE)) mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ...", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) ## Search env <- envir while (!identical(env, emptyenv())) { mdebug("- searching %s: %s", sQuote(envname(env)), hpaste(sQuote(ls(envir = env, all.names = TRUE)))) if (exists(x, envir = env, mode = mode, inherits = FALSE)) { mdebug(" + found in location: %s", sQuote(envname(env))) mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) #nolint return(env) } if (!inherits) { mdebug(" + failed to locate: NULL") mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) #nolint return(NULL) } env <- parent.env(env) } mdebug("- failed to locate: NULL") mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) NULL } globals/R/Globals-class.R0000644000177700017770000001017013075205110016232 0ustar herbrandtherbrandt#' A representation of a set of globals #' #' @usage Globals(object, ...) #' #' @param object A named list. #' @param \dots Not used. #' #' @return An object of class \code{Future}. #' #' @seealso #' The \code{\link{globalsOf}()} function identifies globals #' from an R expression and returns a Globals object. #' #' @aliases as.Globals as.Globals.Globals as.Globals.list [.Globals names #' @export Globals <- function(object = list(), ...) { if (!is.list(object)) { stop("Argument 'object' is not a list: ", class(object)[1]) } if (length(object) > 0) { names <- names(object) if (is.null(names)) { stop("Argument 'object' must be a named list.") } else if (!all(nzchar(names))) { stop("Argument 'object' specifies globals with empty names.") } } where <- attr(object, "where") if (length(object) == 0 && is.null(where)) { attr(object, "where") <- where <- list() } stopifnot(is.list(where)) stopifnot( is.list(where), length(where) == length(object), length(names(where)) == length(names(object)) ) structure(object, class = c("Globals", class(object))) } #' @export as.Globals <- function(x, ...) UseMethod("as.Globals") #' @export as.Globals.Globals <- function(x, ...) x #' @export as.Globals.list <- function(x, ...) { ## Use the globals environments as the locals? ## (with emptyenv() as the fallback) where <- attr(x, "where") if (is.null(where)) { where <- lapply(x, FUN = function(obj) { e <- environment(obj) if (is.null(e)) e <- emptyenv() e }) names(where) <- names(x) attr(x, "where") <- where } Globals(x, ...) } #' @export `names<-.Globals` <- function(x, value) { x <- NextMethod("names") where <- attr(x, "where") names(where) <- names(x) attr(x, "where") <- where invisible(x) } #' @export `[.Globals` <- function(x, i) { where <- attr(x, "where") res <- NextMethod("[") attr(res, "where") <- where[i] class(res) <- class(x) where <- attr(res, "where") stopifnot( is.list(where), length(where) == length(res), length(names(where)) == length(names(res)) ) res } #' @export `$<-.Globals` <- function(x, name, value) { where <- attr(x, "where") ## Remove an element? if (is.null(value)) { x[[name]] <- NULL where[[name]] <- NULL } else { ## Value must be Globals object of length one if (inherits(value, "Globals")) { if (length(value) != 1) { stop("Cannot assign Globals object of length different than one: ", length(value)) } x[[name]] <- value[[1]] where[[name]] <- attr(value, "where")[[1]] } else { w <- environment(value) if (is.null(w)) w <- emptyenv() x[[name]] <- value where[[name]] <- w } } attr(x, "where") <- where invisible(x) } #' @export c.Globals <- function(x, ...) { args <- list(...) where <- attr(x, "where") clazz <- class(x) class(x) <- NULL for (kk in seq_along(args)) { g <- args[[kk]] name <- names(args)[kk] if (inherits(g, "Globals")) { w <- attr(g, "where") } else if (is.list(g)) { ## Nothing to do? if (length(g) == 0) next names <- names(g) stopifnot(!is.null(names)) w <- lapply(g, FUN = function(obj) { e <- environment(obj) if (is.null(e)) e <- emptyenv() e }) names(w) <- names } else { if (is.null(name)) { stop("Can only append named objects to Globals list: ", sQuote(mode(g))) } g <- structure(list(g), names = name) e <- environment(g) if (is.null(e)) e <- emptyenv() w <- structure(list(e), names = name) } where <- c(where, w) x <- c(x, g) } class(x) <- clazz attr(x, "where") <- where stopifnot( length(where) == length(x), all(names(where) == names(x)) ) x } #' @export unique.Globals <- function(x, ...) { names <- names(x) dups <- duplicated(names) if (any(dups)) { where <- attr(x, "where") where <- where[!dups] x <- x[!dups] attr(x, "where") <- where stopifnot( length(where) == length(x), all(names(where) == names(x)) ) } x } globals/R/findGlobals.R0000644000177700017770000002221213225226121015772 0ustar herbrandtherbrandt## This function is equivalent to: ## fun <- as_function(expr, envir = envir, ...) ## codetools::findGlobals(fun, merge = TRUE) ## but we expand it here to make it more explicit ## what is going on. #' @importFrom codetools makeUsageCollector findLocalsList walkCode find_globals_conservative <- function(expr, envir, ..., trace = FALSE) { objs <- character() enter <- function(type, v, e, w) { objs <<- c(objs, v) } if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) # e.g. `<-` fun <- expr w <- makeUsageCollector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w) } else { ## From codetools::findGlobals(): fun <- as_function(expr, envir = envir, ...) # codetools::collectUsage(fun, enterGlobal = enter) ## The latter becomes equivalent to (after cleanup): w <- makeUsageCollector(fun, name = "", enterGlobal = enter) w$env <- new.env(hash = TRUE, parent = w$env) if (trace) w <- inject_tracer_to_walker(w) locals <- findLocalsList(list(expr)) for (name in locals) assign(name, value = TRUE, envir = w$env) walkCode(expr, w) } unique(objs) } #' @importFrom codetools makeUsageCollector walkCode find_globals_liberal <- function(expr, envir, ..., trace = FALSE) { objs <- character() enter <- function(type, v, e, w) { objs <<- c(objs, v) } if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-` fun <- expr w <- makeUsageCollector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w) } else { fun <- as_function(expr, envir = envir, ...) w <- makeUsageCollector(fun, name = "", enterGlobal = enter) if (trace) w <- inject_tracer_to_walker(w) walkCode(expr, w) } unique(objs) } #' @importFrom codetools makeUsageCollector walkCode find_globals_ordered <- function(expr, envir, ..., trace = FALSE) { class <- name <- character() enter_local <- function(type, v, e, w) { ## LH <- RH: Handle cases where a global variable exists in RH and LH ## assigns a local variable with the same name, e.g. x <- x + 1. ## In such case we want to detect 'x' as a global variable. if (type == "<-" && getOption("globals.selfassign", TRUE)) { globals <- all.names(e[[3]], unique = TRUE) if (v %in% globals) { class <<- c(class, "global") name <<- c(name, v) } } class <<- c(class, "local") name <<- c(name, v) } enter_global <- function(type, v, e, w) { class <<- c(class, "global") name <<- c(name, v) ## Also walk formulas to identify globals if (type == "function") { if (v == "~") { stopifnot(identical(e[[1]], as.symbol("~"))) expr <- e[-1] for (kk in seq_along(expr)) { globals <- find_globals_ordered(expr = expr[[kk]], envir = w$env) if (length(globals) > 0) { class <<- c(class, rep("global", times = length(globals))) name <<- c(name, globals) } } } } } ## A function or an expression? if (is.function(expr)) { if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-` fun <- expr w <- makeUsageCollector(fun, name = "", enterLocal = enter_local, enterGlobal = enter_global) if (trace) w <- inject_tracer_to_walker(w) collect_usage_function(fun, name = "", w) } else { fun <- as_function(expr, envir = envir, ...) w <- makeUsageCollector(fun, name = "", enterLocal = enter_local, enterGlobal = enter_global) if (trace) w <- inject_tracer_to_walker(w) walkCode(expr, w) } ## Drop duplicated names dups <- duplicated(name) class <- class[!dups] name <- name[!dups] unique(name[class == "global"]) } #' @export findGlobals <- function(expr, envir = parent.frame(), ..., tweak = NULL, dotdotdot = c("warning", "error", "return", "ignore"), method = c("ordered", "conservative", "liberal"), substitute = FALSE, unlist = TRUE, trace = FALSE) { method <- match.arg(method) dotdotdot <- match.arg(dotdotdot) if (substitute) expr <- substitute(expr) mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ...", dotdotdot, method, unlist) if (is.list(expr)) { mdebug(" - expr: ", length(expr)) globals <- lapply(expr, FUN = findGlobals, envir = envir, ..., tweak = tweak, dotdotdot = dotdotdot, substitute = FALSE, unlist = FALSE) mdebug(" - preliminary globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) if (unlist) { needs_dotdotdot <- FALSE for (kk in seq_along(globals)) { s <- globals[[kk]] n <- length(s) if (identical(s[n], "...")) { needs_dotdotdot <- TRUE s <- s[-n] globals[[kk]] <- s } } globals <- unlist(globals, use.names = TRUE) globals <- sort(unique(globals)) if (needs_dotdotdot) globals <- c(globals, "...") } mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint return(globals) } if (is.function(tweak)) { mdebug(" - tweaking expression using function") expr <- tweak(expr) } if (method == "ordered") { find_globals_t <- find_globals_ordered } else if (method == "conservative") { find_globals_t <- find_globals_conservative } else if (method == "liberal") { find_globals_t <- find_globals_liberal } ## Is there a need for global '...' variables? needs_dotdotdot <- FALSE globals <- withCallingHandlers({ oopts <- options(warn = 0L) on.exit(options(oopts)) find_globals_t(expr, envir = envir, trace = trace) }, warning = function(w) { ## Warned about '...'? ## NOTE: The warning we're looking for is the one generated by ## codetools::findGlobals(). That warning is _not_ translated, ## meaning this approach should work as is as long as the message ## is not modified by codetools itself. If codetools ever changes ## this such that the below string matching fails, then the package ## tests (tests/dotdotdot.R) will detect that. In other words, ## such a change will not go unnoticed. /HB 2017-03-08 pattern <- "... may be used in an incorrect context" if (grepl(pattern, w$message, fixed = TRUE)) { mdebug(" - detected: %s", dQuote(trim(w$message))) needs_dotdotdot <<- TRUE if (dotdotdot == "return") { ## Consume / muffle warning invokeRestart("muffleWarning") } else if (dotdotdot == "ignore") { needs_dotdotdot <<- FALSE ## Consume / muffle warning invokeRestart("muffleWarning") } else if (dotdotdot == "error") { e <- simpleError(w$message, w$call) stop(e) } } }) if (needs_dotdotdot) globals <- c(globals, "...") mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(globals))) mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint globals } ## Utility functions adopted from codetools:::dropMissing() ## and codetools:::collectUsageFun() drop_missing_formals <- function(x) { nx <- length(x) ix <- logical(length = nx) for (i in seq_len(nx)) { tmp <- x[[i]] if (!missing(tmp)) ix[i] <- TRUE } x[ix] } #' @importFrom codetools walkCode findLocalsList collect_usage_function <- function(fun, name, w) { formals <- formals(fun) body <- body(fun) w$name <- c(w$name, name) parnames <- names(formals) formals_clean <- drop_missing_formals(formals) locals <- findLocalsList(c(list(body), formals_clean)) w$env <- new.env(hash = TRUE, parent = w$env) for (n in c(parnames, locals)) assign(n, TRUE, w$env) for (a in formals_clean) walkCode(a, w) walkCode(body, w) } inject_tracer_to_function <- function(fcn, name) { b <- body(fcn) f <- formals(fcn) args <- setdiff(names(f), c("w", "...")) title <- sprintf("%s():", name) b <- bquote({ message(.(title)) if (length(.(args)) > 0) { mstr <- get("mstr", envir = getNamespace("globals"), mode = "function") mstr(mget(.(args))) } .(b) }) body(fcn) <- b fcn } inject_tracer_to_walker <- function(w) { if (is.null(w$startCollectLocals)) { w$startCollectLocals <- function(parnames, locals, ...) { NULL } } if (is.null(w$finishCollectLocals)) { w$finishCollectLocals <- function(w, ...) { NULL } } if (is.null(w$enterInternal)) { w$enterInternal <- function(type, v, e, ...) { NULL } } for (key in names(w)) { fcn <- w[[key]] if (!is.function(fcn)) next fcn <- inject_tracer_to_function(fcn, key) w[[key]] <- fcn } w } globals/R/globalsOf.R0000644000177700017770000002077613170230100015462 0ustar herbrandtherbrandt#' Get all global objects of an expression #' #' @param expr An R expression. #' #' @param envir The environment from where to search for globals. #' #' @param \dots Not used. #' #' @param method A character string specifying what type of search algorithm #' to use. #' #' @param tweak An optional function that takes an expression #' and returns a tweaked expression. #' #' @param substitute If TRUE, the expression is \code{substitute()}:ed, #' otherwise not. #' #' @param mustExist If TRUE, an error is thrown if the object of the #' identified global cannot be located. Otherwise, the global #' is not returned. #' #' @param unlist If TRUE, a list of unique objects is returned. #' If FALSE, a list of \code{length(expr)} sublists. #' #' @param recursive If TRUE, globals that are closures (functions) and that #' exist outside of namespaces ("packages"), will be recursively #' scanned for globals. #' #' @param skip (internal) A list of globals not to be searched for #' additional globals. Ignored unless \code{recursive} is TRUE. #' #' @return A \link{Globals} object. #' #' @details #' There currently three methods for identifying global objects. #' #' The \code{"ordered"} search method identifies globals such that #' a global variable preceding a local variable with the same name #' is not dropped (which the \code{"conservative"} method would). #' #' The \code{"conservative"} search method tries to keep the number #' of false positive to a minimum, i.e. the identified objects are #' most likely true global objects. At the same time, there is #' a risk that some true globals are not identified (see example). #' This search method returns the exact same result as the #' \code{\link[codetools]{findGlobals}()} function of the #' \pkg{codetools} package. #' #' The \code{"liberal"} search method tries to keep the #' true-positive ratio as high as possible, i.e. the true globals #' are most likely among the identified ones. At the same time, #' there is a risk that some false positives are also identified. #' #' With \code{recursive = TRUE}, globals part of locally defined #' functions will also be found, otherwise not. #' #' @example incl/globalsOf.R #' #' @seealso #' Internally, the \pkg{\link{codetools}} package is utilized for #' code inspections. #' #' @aliases findGlobals #' @export globalsOf <- function(expr, envir = parent.frame(), ..., method = c("ordered", "conservative", "liberal"), tweak = NULL, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL) { method <- match.arg(method) if (substitute) expr <- substitute(expr) stopifnot(is.null(skip) || is.list(skip)) mdebug("globalsOf(..., method = '%s', mustExist = %s, unlist = %s, recursive = %s) ...", method, mustExist, unlist, recursive) #nolint ## 1. Identify global variables (static code inspection) names <- findGlobals(expr, envir = envir, ..., method = method, tweak = tweak, substitute = FALSE, unlist = unlist) mdebug(" - preliminary globals (by name): [%d] %s", length(names), hpaste(sQuote(names))) ## 2. Locate them (run time) globals <- tryCatch({ globalsByName(names, envir = envir, mustExist = mustExist) }, error = function(ex) { ## HACK: Tweak error message to also include the expression inspected. msg <- conditionMessage(ex) msg <- sprintf("Identified global objects via static code inspection (%s). %s", hexpr(expr), msg) #nolint ex$message <- msg stop(ex) }) mdebug(" - preliminary globals (by value): [%d] %s", length(globals), hpaste(sQuote(names(globals)))) ## 3. Among globals that are closures (functions) and that exist outside ## of namespaces ("packages"), check for additional globals? if (recursive) { mdebug(" - recursive scan of preliminary globals ...") ## Don't enter functions in namespaces / packages where <- attr(globals, "where") stopifnot(length(where) == length(globals)) where <- sapply(where, FUN = envname) globals_t <- globals[!(where %in% loadedNamespaces())] mdebug(" - subset of globals to be scanned (not in loaded namespaces): [%d] %s", length(globals_t), hpaste(sQuote(names(globals_t)))) #nolint ## Enter only functions ## NOTE: This excludes functions "not found", but also primitives ## not dropped above. globals_t <- globals_t[sapply(globals_t, FUN = typeof) == "closure"] if (length(globals_t) > 0) { mdebug(" - subset of globals to be scanned: [%d] %s", length(globals_t), hpaste(sQuote(names(globals_t)))) names_t <- names(globals_t) ## Avoid recursive scanning of already scanned ("known") globals skip_t <- c(skip, globals_t) for (gg in seq_along(globals_t)) { mdebug(" + scanning global #%d (%s) ...", gg, sQuote(names_t[[gg]])) fcn <- globals_t[[gg]] ## Is function 'fcn' among the already identified globals? already_scanned <- any(sapply(skip, FUN = identical, fcn)) if (already_scanned) next; env <- environment(fcn) ## was 'env <- envir' in globals 0.8.0. globals_gg <- globalsOf(fcn, envir = env, ..., method = method, tweak = tweak, substitute = FALSE, mustExist = mustExist, unlist = unlist, recursive = recursive, skip = skip_t) if (length(globals_gg) > 0) { globals <- c(globals, globals_gg) skip_gg <- globals_gg[sapply(globals_gg, FUN = typeof) == "closure"] skip_t <- c(skip_t, skip_gg) } } globals <- unique(globals) mdebug(" - updated set of globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) } else { mdebug(" - subset of globals to be scanned: [0]") } mdebug(" - recursive scan of preliminary globals ... DONE") } mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(names(globals)))) mdebug("globalsOf(..., method = '%s', mustExist = %s, unlist = %s, recursive = %s) ... DONE", method, mustExist, unlist, recursive) #nolint globals } ## globalsOf() #' Locates and retrieves a set of global variables by their names #' #' @param names A character vector of global variable names. #' @param envir The environment from where to search for globals. #' @param mustExist If TRUE, an error is thrown if the object of the #' identified global cannot be located. Otherwise, the global #' is not returned. #' @param ... Not used. #' #' @return A \link{Globals} object. #' #' @export globalsByName <- function(names, envir = parent.frame(), mustExist = TRUE, ...) { names <- as.character(names) mdebug("globalsByName(<%d names>, mustExist = %s) ...", length(names), mustExist) mdebug("- search from environment: %s", sQuote(envname(envir))) ## Locate and retrieve the specified globals n <- length(names) needs_dotdotdot <- (identical(names[n], "...")) if (needs_dotdotdot) names <- names[-n] mdebug("- dotdotdot: %s", needs_dotdotdot) globals <- structure(list(), class = c("Globals", "list")) where <- list() for (kk in seq_along(names)) { name <- names[kk] mdebug("- locating #%d (%s)", kk, sQuote(name)) env <- where(name, envir = envir, inherits = TRUE) mdebug(" + found in environment: %s", sQuote(envname(env))) if (!is.null(env)) { where[[name]] <- env value <- get(name, envir = env, inherits = FALSE) if (is.null(value)) { globals[name] <- list(NULL) } else { globals[[name]] <- value } } else { globals[name] <- list(NULL) where[name] <- list(NULL) if (mustExist) { stop(sprintf("Failed to locate global object in the relevant environments: %s", sQuote(name))) #nolint } } } if (needs_dotdotdot) { if (exists("...", envir = envir, inherits = TRUE)) { where[["..."]] <- where("...", envir = envir, inherits = TRUE) ddd <- evalq(list(...), envir = envir, enclos = envir) } else { where["..."] <- list(NULL) ddd <- NA } class(ddd) <- c("DotDotDotList", class(ddd)) globals[["..."]] <- ddd } stopifnot( is.list(where), length(where) == length(globals), all(names(where) == names(globals)) ) attr(globals, "where") <- where mdebug("globalsByName(<%d names>, mustExist = %s) ... DONE", length(names), mustExist) globals } ## globalsByName() globals/MD50000644000177700017770000000240313225441521013535 0ustar herbrandtherbrandt9c5a658bd1344138a3973001b377a125 *DESCRIPTION d4e67a0b46da2e77005cf43852f8b483 *NAMESPACE f8b37e8a42a50e4fff9215995def15eb *NEWS 4cae63bc2a767f0522c0943358e99d6f *R/Globals-class.R bcb4032fbccd0e0c961146919372ffbc *R/cleanup.R 0ac0525c3d1c00f4440447f434068780 *R/findGlobals.R dd28303e3b38b94664f082b69e858105 *R/globalsOf.R a3bb9fec59515b028f65771de5f47315 *R/packagesOf.R b8d1ead15928e1cf62164fdf63fbc939 *R/utils.R 378b34c7d7031f615af88b52de72f936 *R/walkAST.R 02769684a9ccbf65df50900fb885496b *R/where.R abec206d57e9f3f4d34bb4a875d35490 *man/Globals.Rd 978342cde4007f1977a2a355dabf6ffa *man/cleanup.Globals.Rd fc7000ee5990508042e8b53ede23dae1 *man/globalsByName.Rd b3557e2741ae0c038c9f65ffdcda804a *man/globalsOf.Rd 71d33dd463fd36bf678fcf037e0d62aa *man/packagesOf.Globals.Rd 7520df319b9afd0c632d73ae339af702 *man/walkAST.Rd 97257c489172ab40d42d209b6ae579ee *tests/Globals.R 5c5558c14915e4f98844ac49f39be46b *tests/conservative.R e373e47a402e06c64c0f7d18b0c78508 *tests/dotdotdot.R e3e4b49566be287f8beeeaf1346f6ca9 *tests/formulas.R 3552eeea5c4a3261e0b2b87bd218ee0f *tests/globalsOf.R 574e081fe6528451f152c2c1239ce806 *tests/liberal.R 3058995bc5b96840c58c0c4219d3e018 *tests/utils.R c9bb0296119e85b060ad2a6bce2a4315 *tests/walkAST.R 7af53138f87e6ef0f9333c9b8176c51d *tests/zzz.R globals/DESCRIPTION0000644000177700017770000000170013225441521014732 0ustar herbrandtherbrandtPackage: globals Version: 0.11.0 Depends: R (>= 3.1.2) Imports: codetools Title: Identify Global Objects in R Expressions Authors@R: c( person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"), email="henrikb@braju.com")) Description: Identifies global ("unknown" or "free") objects in R expressions by code inspection using various strategies, e.g. conservative or liberal. The objective of this package is to make it as simple as possible to identify global objects for the purpose of exporting them in distributed compute environments. License: LGPL (>= 2.1) LazyLoad: TRUE ByteCompile: TRUE URL: https://github.com/HenrikBengtsson/globals BugReports: https://github.com/HenrikBengtsson/globals/issues RoxygenNote: 6.0.1 NeedsCompilation: no Packaged: 2018-01-10 05:14:29 UTC; hb Author: Henrik Bengtsson [aut, cre, cph] Maintainer: Henrik Bengtsson Repository: CRAN Date/Publication: 2018-01-10 16:46:09 UTC globals/man/0000755000177700017770000000000013170230100013765 5ustar herbrandtherbrandtglobals/man/globalsByName.Rd0000644000177700017770000000127613060642517017022 0ustar herbrandtherbrandt% Generated by roxygen2: do not edit by hand % Please edit documentation in R/globalsOf.R \name{globalsByName} \alias{globalsByName} \title{Locates and retrieves a set of global variables by their names} \usage{ globalsByName(names, envir = parent.frame(), mustExist = TRUE, ...) } \arguments{ \item{names}{A character vector of global variable names.} \item{envir}{The environment from where to search for globals.} \item{mustExist}{If TRUE, an error is thrown if the object of the identified global cannot be located. Otherwise, the global is not returned.} \item{...}{Not used.} } \value{ A \link{Globals} object. } \description{ Locates and retrieves a set of global variables by their names } globals/man/walkAST.Rd0000644000177700017770000000167513075205110015602 0ustar herbrandtherbrandt% Generated by roxygen2: do not edit by hand % Please edit documentation in R/walkAST.R \name{walkAST} \alias{walkAST} \title{Walk the Abstract Syntax Tree (AST) of an R Expression} \usage{ walkAST(expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL, substitute = FALSE) } \arguments{ \item{expr}{R \link[base]{expression}.} \item{atomic, name, call, pairlist}{single-argument function that takes an atomic, name, call and pairlist expression, respectively. Have to return a valid R expression.} \item{name}{single-argument function that takes a name expression.} \item{call}{single-argument function that takes a call expression.} \item{pairlist}{single-argument function that takes a pairlist expression.} \item{substitute}{If TRUE, \code{expr} is \code{\link[base]{substitute}()}:ed.} } \value{ R \link[base]{expression}. } \description{ Walk the Abstract Syntax Tree (AST) of an R Expression } \keyword{internal} \keyword{programming} globals/man/packagesOf.Globals.Rd0000644000177700017770000000067213060642517017727 0ustar herbrandtherbrandt% Generated by roxygen2: do not edit by hand % Please edit documentation in R/packagesOf.R \name{packagesOf.Globals} \alias{packagesOf.Globals} \alias{packagesOf} \title{Identify the packages of the globals} \usage{ \method{packagesOf}{Globals}(globals, ...) } \arguments{ \item{globals}{A Globals object.} \item{\dots}{Not used.} } \value{ Returns a character vector of package names. } \description{ Identify the packages of the globals } globals/man/cleanup.Globals.Rd0000644000177700017770000000072513060642517017312 0ustar herbrandtherbrandt% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cleanup.R \name{cleanup.Globals} \alias{cleanup.Globals} \alias{cleanup} \title{Drop certain types of globals} \usage{ \method{cleanup}{Globals}(globals, drop = c("missing", "base-packages"), ...) } \arguments{ \item{globals}{A Globals object.} \item{drop}{A character vector specifying what type of globals to drop.} \item{\dots}{Not used} } \description{ Drop certain types of globals } globals/man/globalsOf.Rd0000644000177700017770000000536413170230100016174 0ustar herbrandtherbrandt% Generated by roxygen2: do not edit by hand % Please edit documentation in R/globalsOf.R \name{globalsOf} \alias{globalsOf} \alias{findGlobals} \title{Get all global objects of an expression} \usage{ globalsOf(expr, envir = parent.frame(), ..., method = c("ordered", "conservative", "liberal"), tweak = NULL, substitute = FALSE, mustExist = TRUE, unlist = TRUE, recursive = TRUE, skip = NULL) } \arguments{ \item{expr}{An R expression.} \item{envir}{The environment from where to search for globals.} \item{\dots}{Not used.} \item{method}{A character string specifying what type of search algorithm to use.} \item{tweak}{An optional function that takes an expression and returns a tweaked expression.} \item{substitute}{If TRUE, the expression is \code{substitute()}:ed, otherwise not.} \item{mustExist}{If TRUE, an error is thrown if the object of the identified global cannot be located. Otherwise, the global is not returned.} \item{unlist}{If TRUE, a list of unique objects is returned. If FALSE, a list of \code{length(expr)} sublists.} \item{recursive}{If TRUE, globals that are closures (functions) and that exist outside of namespaces ("packages"), will be recursively scanned for globals.} \item{skip}{(internal) A list of globals not to be searched for additional globals. Ignored unless \code{recursive} is TRUE.} } \value{ A \link{Globals} object. } \description{ Get all global objects of an expression } \details{ There currently three methods for identifying global objects. The \code{"ordered"} search method identifies globals such that a global variable preceding a local variable with the same name is not dropped (which the \code{"conservative"} method would). The \code{"conservative"} search method tries to keep the number of false positive to a minimum, i.e. the identified objects are most likely true global objects. At the same time, there is a risk that some true globals are not identified (see example). This search method returns the exact same result as the \code{\link[codetools]{findGlobals}()} function of the \pkg{codetools} package. The \code{"liberal"} search method tries to keep the true-positive ratio as high as possible, i.e. the true globals are most likely among the identified ones. At the same time, there is a risk that some false positives are also identified. With \code{recursive = TRUE}, globals part of locally defined functions will also be found, otherwise not. } \examples{ b <- 2 expr <- substitute({ a <- b; b <- 1 }) ## Will _not_ identify 'b' (because it's also a local) globalsC <- globalsOf(expr, method = "conservative") print(globalsC) ## Will identify 'b' globalsL <- globalsOf(expr, method = "liberal") print(globalsL) } \seealso{ Internally, the \pkg{\link{codetools}} package is utilized for code inspections. } globals/man/Globals.Rd0000644000177700017770000000111513060642517015656 0ustar herbrandtherbrandt% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Globals-class.R \name{Globals} \alias{Globals} \alias{as.Globals} \alias{as.Globals.Globals} \alias{as.Globals.list} \alias{[.Globals} \alias{names} \title{A representation of a set of globals} \usage{ Globals(object, ...) } \arguments{ \item{object}{A named list.} \item{\dots}{Not used.} } \value{ An object of class \code{Future}. } \description{ A representation of a set of globals } \seealso{ The \code{\link{globalsOf}()} function identifies globals from an R expression and returns a Globals object. }