globals/0000755000176200001440000000000013037253767011712 5ustar liggesusersglobals/tests/0000755000176200001440000000000013037234152013037 5ustar liggesusersglobals/tests/utils.R0000644000176200001440000000664712764363367014360 0ustar liggesuserslibrary("globals") message("*** utils ...") asFunction <- globals:::asFunction findBasePkgs <- globals:::findBasePkgs isBasePkgs <- globals:::isBasePkgs is.base <- globals:::is.base is.internal <- globals:::is.internal where <- globals:::where ## 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, maxHead=2)) ## x = 1, 2, ..., 6. printf("x = %s.\n", hpaste(x), maxHead=3) # Default ## x = 1, 2, 3, ..., 6. # It will never output 1, 2, 3, 4, ..., 6 printf("x = %s.\n", hpaste(x, maxHead=4)) ## x = 1, 2, 3, 4, 5 and 6. # Showing the tail printf("x = %s.\n", hpaste(x, maxHead=1, maxTail=2)) ## x = 1, ..., 5, 6. # Turning off abbreviation printf("y = %s.\n", hpaste(y, maxHead=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, lastCollapse=" 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("* asFunction() ...") fcn <- asFunction({ 1 }) print(fcn()) stopifnot(fcn() == 1) message("* findBasePkgs() & isBasePkgs() ...") basePkgs <- findBasePkgs() print(basePkgs) stopifnot(length(basePkgs) > 1L) for (pkg in basePkgs) { stopifnot(isBasePkgs(pkg)) } stopifnot(!isBasePkgs("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 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("*** utils ... DONE") globals/tests/conservative.R0000644000176200001440000000413312726157532015705 0ustar liggesuserslibrary("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.R0000644000176200001440000000412012726157532014603 0ustar liggesuserslibrary("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.R0000644000176200001440000001325412765663167015216 0ustar liggesuserslibrary("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:::asFunction(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, ...) { 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) message("*** function(x, ...) globalsOf() ... DONE") ## Undo options(opts) globals/tests/walkAST.R0000644000176200001440000000441313000075336014467 0ustar liggesuserslibrary("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) ) nullify <- function(e) NULL disp <- function(expr) { cat("Expression:\n") print(expr) cat("str():\n") str(expr) cat(sprintf("typeof: %s\n", typeof(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]] print(expr) str(as.list(expr)) ## Assert identity (default behavior) exprI <- walkAST(expr) str(as.list(exprI)) res <- all.equal(exprI, expr) print(res) if (!identical(exprI, expr)) saveRDS(list(expr=expr, exprI=exprI), file="/tmp/foo.rds") stopifnot(length(exprI) == length(expr), identical(exprI, expr)) ## Display the AST tree walkAST(expr, atomic=disp, name=disp, call=disp, pairlist=disp) ## Nullify exprN <- walkAST(expr, atomic=nullify, name=nullify, call=nullify, pairlist=nullify) print(exprN) str(as.list(exprN)) 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 ...") res <- tryCatch({ expr <- walkAST(list()) }, error = identity) print(res) stopifnot(inherits(res, "simpleError")) message("*** walkAST() - exceptions ... DONE") message("*** walkAST() ... DONE") globals/tests/Globals.R0000644000176200001440000001423313035210406014542 0ustar liggesuserslibrary("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 ...") globalsA <- globals0[1:2] globalsB <- globals0[1:2] globals <- c(globalsA, globalsB) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globalsA), names(globalsB))), all(names(globals) == names(where)) ) globalsA <- globals0[1:2] globalsB <- list(b=1, c=letters) globals <- c(globalsA, globalsB) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globalsA), names(globalsB))), all(names(globals) == names(where)) ) globalsA <- globals0[1:2] globalsB <- list() globals <- c(globalsA, globalsB) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 2L, length(where) == length(globals), all(names(globals) == c(names(globalsA), names(globalsB))), all(names(globals) == names(where)) ) globalsA <- globals0[1:2] globals <- c(globalsA, b=1, c=letters) str(globals) where <- attr(globals, "where") stopifnot( length(globals) == 4L, length(where) == length(globals), all(names(globals) == c(names(globalsA), "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)) globalsT <- unclass(globals0) attr(globalsT, "where") <- NULL globals <- as.Globals(globalsT) 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.R0000644000176200001440000001653113037224646015107 0ustar liggesuserslibrary("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) } b <- 2 c <- 3 d <- NULL expr <- substitute({ x <- b; b <- 1; y <- c; z <- d }, env=list()) message("*** findGlobals() ...") message(" ** findGlobals(..., method='conservative'):") globalsC <- findGlobals(expr, method="conservative") print(globalsC) stopifnot(all(globalsC %in% c("{", "<-", "c", "d"))) message(" ** findGlobals(..., method='liberal'):") globalsL <- findGlobals(expr, method="liberal") print(globalsL) stopifnot(all(globalsL %in% c("{", "<-", "b", "c", "d"))) message(" ** findGlobals(..., method='ordered'):") globalsI <- findGlobals(expr, method="ordered") print(globalsI) stopifnot(all(globalsI %in% c("{", "<-", "b", "c", "d"))) message("*** findGlobals() ... DONE") message("*** globalsByName() ...") globalsC <- globalsByName(c("{", "<-", "c", "d")) str(globalsC) stopifnot(all(names(globalsC) %in% c("{", "<-", "c", "d"))) globalsC <- cleanup(globalsC) str(globalsC) stopifnot(all(names(globalsC) %in% c("c", "d"))) where <- attr(globalsC, "where") stopifnot( length(where) == length(globalsC), identical(where$c, globalenv()), identical(where$d, globalenv()) ) foo <- globals::Globals globals <- globalsByName(c("{", "foo", "list")) 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'):") globalsC <- globalsOf(expr, method="conservative") str(globalsC) stopifnot(all(names(globalsC) %in% c("{", "<-", "c", "d"))) globalsC <- cleanup(globalsC) str(globalsC) stopifnot(all(names(globalsC) %in% c("c", "d"))) where <- attr(globalsC, "where") stopifnot( length(where) == length(globalsC), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf(..., method='liberal'):") globalsL <- globalsOf(expr, method="liberal") str(globalsL) stopifnot(all(names(globalsL) %in% c("{", "<-", "b", "c", "d"))) globalsL <- cleanup(globalsL) str(globalsL) stopifnot(all(names(globalsL) %in% c("b", "c", "d"))) where <- attr(globalsL, "where") stopifnot( length(where) == length(globalsL), identical(where$b, globalenv()), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf(..., method='ordered'):") globalsL <- globalsOf(expr, method="ordered") str(globalsL) stopifnot(all(names(globalsL) %in% c("{", "<-", "b", "c", "d"))) globalsL <- cleanup(globalsL) str(globalsL) stopifnot(all(names(globalsL) %in% c("b", "c", "d"))) where <- attr(globalsL, "where") stopifnot( length(where) == length(globalsL), identical(where$b, globalenv()), identical(where$c, globalenv()), identical(where$d, globalenv()) ) message(" ** globalsOf() w/ globals in local functions:") a <- 1 foo <- function(x) x - a for (method in c("ordered", "conservative", "liberal")) { globalsL <- globalsOf({ foo(3) }, substitute = TRUE, method = method, recursive = FALSE, mustExist = FALSE) stopifnot(all(names(globalsL) %in% c("{", "foo")), !any("a" %in% names(globalsL))) globalsL <- cleanup(globalsL) str(globalsL) stopifnot(all(names(globalsL) %in% c("foo"), !any("a" %in% names(globalsL)))) globalsL <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered", recursive = TRUE, mustExist = FALSE) stopifnot(all(names(globalsL) %in% c("{", "foo", "-", "a"))) globalsL <- cleanup(globalsL) str(globalsL) stopifnot(all(names(globalsL) %in% c("foo", "a"))) globalsL <- globalsOf({ foo(3) }, substitute = TRUE, recursive = TRUE, mustExist = FALSE) stopifnot(all(names(globalsL) %in% c("{", "foo", "-", "a"))) globalsL <- cleanup(globalsL) str(globalsL) stopifnot(all(names(globalsL) %in% c("foo", "a"))) } message("*** globalsOf() ... DONE") message("*** Subsetting of Globals:") globalsL <- globalsOf(expr, method="liberal") globalsS <- globalsL[-1] stopifnot(length(globalsS) == length(globalsL) - 1L) stopifnot(identical(class(globalsS), class(globalsL))) whereL <- attr(globalsL, "where") whereS <- attr(globalsS, "where") stopifnot(length(whereS) == length(whereL) - 1L) stopifnot(identical(whereS, whereL[-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) 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) 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.R0000644000176200001440000000003512764363367014036 0ustar liggesusers## Just a dummy place holder globals/NAMESPACE0000644000176200001440000000106712764363367013141 0ustar liggesusers# 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,installed.packages) globals/NEWS0000644000176200001440000000664613037234127012412 0ustar liggesusersPackage: globals ================ 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/0000755000176200001440000000000013037234024012074 5ustar liggesusersglobals/R/packagesOf.R0000644000176200001440000000161612726157532014302 0ustar liggesusers#' @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.R0000644000176200001440000000517713036530046013373 0ustar liggesusersasFunction <- function(expr, envir=parent.frame(), ...) { eval(substitute(function() x, list(x=expr)), envir=envir, ...) } #' @importFrom utils installed.packages findBasePkgs <- local({ pkgs <- NULL function() { if (length(pkgs) > 0L) return(pkgs) data <- installed.packages() isBase <- (data[,"Priority"] %in% "base") pkgs <<- rownames(data)[isBase] pkgs } }) isBasePkgs <- function(pkgs) { pkgs <- gsub("^package:", "", pkgs) pkgs %in% findBasePkgs() } # cf. is.primitive() is.base <- function(x) { if (typeof(x) != "closure") return(FALSE) isBasePkgs(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)) } ## 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) { tt <- 1 ## Validate arguments stopifnot(is.environment(envir)) stopifnot(is.character(mode), length(mode) == 1L) inherits <- as.logical(inherits) stopifnot(inherits %in% c(FALSE, TRUE)) ## Search while (!identical(envir, emptyenv())) { if (exists(x, envir=envir, mode=mode, inherits=FALSE)) return(envir) if (!inherits) return(NULL) envir <- parent.env(envir) } NULL } ## From R.utils 2.0.2 (2015-05-23) hpaste <- function(..., sep="", collapse=", ", lastCollapse=NULL, maxHead=if (missing(lastCollapse)) 3 else Inf, maxTail=if (is.finite(maxHead)) 1 else Inf, abbreviate="...") { if (is.null(lastCollapse)) lastCollapse <- 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 > maxHead + maxTail + 1) { head <- x[seq_len(maxHead)] tail <- rev(rev(x)[seq_len(maxTail)]) x <- c(head, abbreviate, tail) n <- length(x) } if (!is.null(collapse) && n > 1) { if (lastCollapse == collapse) { x <- paste(x, collapse=collapse) } else { xT <- paste(x[1:(n-1)], collapse=collapse) x <- paste(xT, x[n], sep=lastCollapse) } } x } # hpaste() ## 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="; ", maxHead=6L, maxTail=3L, ...) { code <- deparse(expr) if (trim) code <- trim(code) hpaste(code, collapse=collapse, maxHead=maxHead, maxTail=maxTail, ...) } # hexpr() globals/R/cleanup.R0000644000176200001440000000234412764363367013674 0ustar liggesusers#' @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 (isBasePkgs(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 } # cleanup() globals/R/walkAST.R0000644000176200001440000000461113000075336013526 0ustar liggesusers#' 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 { stop("Cannot walk expression. Unknown object type ", sQuote(typeof(expr)), call.=FALSE) } ## Assert that the tweak functions return a valid object if (!missing(expr)) { stopifnot(is.atomic(expr) || is.name(expr) || is.call(expr) || is.pairlist(expr)) } expr } ## walkAST() globals/R/Globals-class.R0000644000176200001440000001033113035210406014677 0ustar liggesusers#' 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)) ## TODO: Add only when future (> 1.0.1) is on CRAN /HB 2016-09-05 ## stopifnot( ## is.list(where), ## length(where) == length(object), ## all(names(where) == names) ## ) 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) ## TODO: Add only when future (> 1.0.1) is on CRAN /HB 2016-09-05 ## where <- attr(res, "where") ## stopifnot( ## is.list(where), ## length(where) == length(res), ## all(names(where) == 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.R0000644000176200001440000001271413036547432014461 0ustar liggesusers## This function is equivalent to: ## fun <- asFunction(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 findGlobals_conservative <- function(expr, envir, ...) { 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) collectUsageFunction(fun, name="", w) } else { ## From codetools::findGlobals(): fun <- asFunction(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) locals <- findLocalsList(list(expr)) for (name in locals) assign(name, value=TRUE, envir=w$env) walkCode(expr, w) } unique(objs) } #' @importFrom codetools makeUsageCollector walkCode findGlobals_liberal <- function(expr, envir, ...) { 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) collectUsageFunction(fun, name="", w) } else { fun <- asFunction(expr, envir=envir, ...) w <- makeUsageCollector(fun, name="", enterGlobal=enter) walkCode(expr, w) } unique(objs) } #' @importFrom codetools makeUsageCollector walkCode findGlobals_ordered <- function(expr, envir, ...) { class <- name <- character() enterLocal <- function(type, v, e, w) { class <<- c(class, "local") name <<- c(name, v) } enterGlobal <- function(type, v, e, w) { class <<- c(class, "global") name <<- c(name, v) } ## 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=enterLocal, enterGlobal=enterGlobal) collectUsageFunction(fun, name="", w) } else { fun <- asFunction(expr, envir=envir, ...) w <- makeUsageCollector(fun, name="", enterLocal=enterLocal, enterGlobal=enterGlobal) 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) { method <- match.arg(method) dotdotdot <- match.arg(dotdotdot) if (substitute) expr <- substitute(expr) if (is.list(expr)) { globals <- lapply(expr, FUN=findGlobals, envir=envir, ..., tweak=tweak, dotdotdot=dotdotdot, substitute=FALSE, unlist=FALSE) if (unlist) { needsDotdotdot <- FALSE for (kk in seq_along(globals)) { s <- globals[[kk]] n <- length(s) if (identical(s[n], "...")) { needsDotdotdot <- TRUE s <- s[-n] globals[[kk]] <- s } } globals <- unlist(globals, use.names=TRUE) globals <- sort(unique(globals)) if (needsDotdotdot) globals <- c(globals, "...") } return(globals) } if (is.function(tweak)) expr <- tweak(expr) if (method == "ordered") { findGlobalsT <- findGlobals_ordered } else if (method == "conservative") { findGlobalsT <- findGlobals_conservative } else if (method == "liberal") { findGlobalsT <- findGlobals_liberal } ## Is there a need for global '...' variables? needsDotdotdot <- FALSE globals <- withCallingHandlers({ oopts <- options(warn=0L) on.exit(options(oopts)) findGlobalsT(expr, envir=envir) }, warning=function(w) { ## Warned about '...'? pattern <- "... may be used in an incorrect context" if (grepl(pattern, w$message, fixed=TRUE)) { needsDotdotdot <<- TRUE if (dotdotdot == "return") { ## Consume / muffle warning invokeRestart("muffleWarning") } else if (dotdotdot == "ignore") { needsDotdotdot <<- FALSE ## Consume / muffle warning invokeRestart("muffleWarning") } else if (dotdotdot == "error") { e <- simpleError(w$message, w$call) stop(e) } } }) if (needsDotdotdot) globals <- c(globals, "...") globals } ## Utility functions adopted from codetools:::dropMissing() ## and codetools:::collectUsageFun() dropMissingFormals <- 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 collectUsageFunction <- function(fun, name, w) { formals <- formals(fun) body <- body(fun) w$name <- c(w$name, name) parnames <- names(formals) formals_clean <- dropMissingFormals(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) } globals/R/globalsOf.R0000644000176200001440000001316413037234024014134 0ustar liggesusers#' 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. #' #' @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) { method <- match.arg(method) if (substitute) expr <- substitute(expr) ## 1. Identify global variables (static code inspection) names <- findGlobals(expr, envir=envir, ..., method=method, tweak=tweak, substitute=FALSE, unlist=unlist) ## 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) ex$message <- msg stop(ex) }) ## 3. Among globals that are closures (functions) and that exist outside ## of namespaces ("packages"), check for additional globals? if (recursive) { ## Don't enter functions in namespaces / packages where <- sapply(globals, FUN = function(x) environmentName(environment(x))) globalsT <- globals[!(where %in% loadedNamespaces())] ## Enter only functions globalsT <- globals[sapply(globalsT, FUN = typeof) == "closure"] if (length(globalsT) > 0) { for (gg in seq_along(globalsT)) { fcn <- globalsT[[gg]] globalsGG <- globalsOf(fcn, envir=envir, ..., method=method, tweak=tweak, substitute=FALSE, mustExist=mustExist, unlist=unlist, recursive=recursive) if (length(globalsGG) > 0) { globals <- c(globals, globalsGG) } } globals <- unique(globals) } } 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) ## Locate and retrieve the specified globals n <- length(names) needsDotdotdot <- (identical(names[n], "...")) if (needsDotdotdot) names <- names[-n] globals <- structure(list(), class=c("Globals", "list")) where <- list() for (name in names) { env <- where(name, envir=envir, inherits=TRUE) 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))) } } } if (needsDotdotdot) { 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 globals } ## globalsByName() globals/MD50000644000176200001440000000224413037253767012224 0ustar liggesusersd69d3e82b199a73a6cd3fb860aba4bf1 *DESCRIPTION 24f2b3be1c6d7a2667c0c0e3a90a9776 *NAMESPACE 4b82fd577ffd37314cd93194ba8d5551 *NEWS e130006674e21564fca015849dfb584f *R/Globals-class.R 2ff62afe0cc2ab9edb6505a1f5ee5a2c *R/cleanup.R 4ec85ed048ac5e6547334c9633956bad *R/findGlobals.R 4f93f392bc2ed30efabaa2360a9bd4d7 *R/globalsOf.R 872b7b7be000da61e173d5be37df37c1 *R/packagesOf.R 4e2a5293b057aa77b586cb457cdf634b *R/utils.R 1759e8aee0418f536cacd508bf33d65b *R/walkAST.R 9d222e6e9bd19dedcf9398fdefddfe06 *man/Globals.Rd 6718bae8bf05b1744df49c2a6345251d *man/cleanup.Globals.Rd e36067883b9755c96195d9f50b4700d1 *man/globalsByName.Rd a30bc35f7e240bcca497bcda1a40ad43 *man/globalsOf.Rd 937c4cb33fb344a0c74330cd162a285c *man/packagesOf.Globals.Rd e4d542b6757e65b7bd8dcee45f46996d *man/walkAST.Rd 60035e1924551a13e4ad79733e0f48a2 *tests/Globals.R 0a4fd4c3594bcf15e685886e0475e528 *tests/conservative.R b840f7e78850bd3a4af136f8649bf05a *tests/dotdotdot.R d7edc642e662195ae2a9f32d4a58169d *tests/globalsOf.R 04ee391b83ac7278c0040be00d32756b *tests/liberal.R 24cf238b33f0f3c7b9ae5e05904d40d8 *tests/utils.R a7d6108d24e35128697e606d16d3c2e5 *tests/walkAST.R 7af53138f87e6ef0f9333c9b8176c51d *tests/zzz.R globals/DESCRIPTION0000644000176200001440000000165513037253767013427 0ustar liggesusersPackage: globals Version: 0.8.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") 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: 5.0.1 NeedsCompilation: no Packaged: 2017-01-16 21:17:30 UTC; hb Author: Henrik Bengtsson [aut, cre, cph] Maintainer: Henrik Bengtsson Repository: CRAN Date/Publication: 2017-01-17 00:32:07 globals/man/0000755000176200001440000000000012764363367012471 5ustar liggesusersglobals/man/globalsByName.Rd0000644000176200001440000000127712764363367015506 0ustar liggesusers% 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.Rd0000644000176200001440000000167612764363367014300 0ustar liggesusers% 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.Rd0000644000176200001440000000067312726157532016404 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/packagesOf.R \name{packagesOf.Globals} \alias{packagesOf} \alias{packagesOf.Globals} \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.Rd0000644000176200001440000000072612764363367015776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cleanup.R \name{cleanup.Globals} \alias{cleanup} \alias{cleanup.Globals} \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.Rd0000644000176200001440000000514413037234037014655 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/globalsOf.R \name{globalsOf} \alias{findGlobals} \alias{globalsOf} \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) } \arguments{ \item{expr}{An R expression.} \item{envir}{The environment from where to search for globals.} \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{\dots}{Not used.} } \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.Rd0000644000176200001440000000111612764363367014342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Globals-class.R \name{Globals} \alias{Globals} \alias{[.Globals} \alias{as.Globals} \alias{as.Globals.Globals} \alias{as.Globals.list} \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. }