Update packages/ Add org-ref
This commit is contained in:
Mateus Pinto Rodrigues
410
elpa/ess-20180611.502/etc/ESSR/R/ns-eval.R
Normal file
410
elpa/ess-20180611.502/etc/ESSR/R/ns-eval.R
Normal file
@@ -0,0 +1,410 @@
|
||||
## NOTE ON S3 METHODS: New S3 methods are not automatically registered. You can
|
||||
## register them manually after you have inserted method_name.my_class into your
|
||||
## package environment using ess-developer, like follows:
|
||||
##
|
||||
## registerS3method("method_name", "my_class", my_package:::method_name.my_class)
|
||||
##
|
||||
## If an S3 methods already exists in a package, ESS-developer will do the right
|
||||
## thing.
|
||||
|
||||
## evaluate the STRING by saving into a file and calling .ess.ns_source
|
||||
.ess.ns_eval <- function(string, visibly, output, package,
|
||||
file = tempfile("ESSDev"), verbose = FALSE,
|
||||
fallback_env = NULL) {
|
||||
cat(string, file = file)
|
||||
on.exit(.ess.file.remove(file))
|
||||
.ess.ns_source(file, visibly, output, package = package,
|
||||
verbose = verbose, fake.source = TRUE,
|
||||
fallback_env = fallback_env)
|
||||
}
|
||||
|
||||
##' Source FILE into an environment. After having a look at each new object in
|
||||
##' the environment, decide what to do with it. Handles plain objects,
|
||||
##' functions, existing S3 methods, S4 classes and methods.
|
||||
##' @param fallback_env environment to assign objects which don't exist in the
|
||||
##' package namespace
|
||||
.ess.ns_source <- function(file, visibly, output, expr,
|
||||
package = "", verbose = FALSE,
|
||||
fake.source = FALSE,
|
||||
fallback_env = NULL) {
|
||||
oldopts <- options(warn = 2)
|
||||
on.exit(options(oldopts))
|
||||
pname <- paste("package:", package, sep = "")
|
||||
envpkg <- tryCatch(as.environment(pname), error = function(cond) NULL)
|
||||
if (is.null(envpkg))
|
||||
if (require(package, quietly = TRUE, character.only = TRUE)) {
|
||||
envpkg <- tryCatch(as.environment(pname), error = function(cond) NULL)
|
||||
} else {
|
||||
## no such package; source in current environment
|
||||
return(.ess.source(file, visibly = visibly,
|
||||
output = output, local = fallback_env,
|
||||
fake.source = fake.source))
|
||||
}
|
||||
|
||||
envns <- tryCatch(asNamespace(package), error = function(cond) NULL)
|
||||
if (is.null(envns))
|
||||
stop(gettextf("Can't find a namespace environment corresponding to package name '%s\"",
|
||||
package), domain = NA)
|
||||
|
||||
## Here we know that both envns and envpkg exists and are environments
|
||||
if (is.null(fallback_env))
|
||||
fallback_env <- .ess.ns_insert_essenv(envns)
|
||||
|
||||
## Get all Imports envs where we propagate objects
|
||||
pkgEnvNames <- Filter(.ess.is_package, search())
|
||||
packages <- lapply(pkgEnvNames, function(envName) substring(envName, 9))
|
||||
importsEnvs <- lapply(packages, function(pkgName) parent.env(asNamespace(pkgName)))
|
||||
|
||||
## Evaluate the FILE into new ENV
|
||||
env <- .ess.ns_evalSource(file, visibly, output, substitute(expr), package, fake.source)
|
||||
envPackage <- getPackageName(env, FALSE)
|
||||
if (nzchar(envPackage) && envPackage != package)
|
||||
warning(gettextf("Supplied package, %s, differs from package inferred from source, %s",
|
||||
sQuote(package), sQuote(envPackage)), domain = NA)
|
||||
|
||||
## Get all sourced objects, methods and classes
|
||||
allObjects <- objects(envir = env, all.names = TRUE)
|
||||
allObjects <- allObjects[!(allObjects %in% c(".cacheOnAssign", ".packageName"))]
|
||||
MetaPattern <- methods:::.TableMetaPattern()
|
||||
ClassPattern <- methods:::.ClassMetaPattern()
|
||||
allPlainObjects <- allObjects[!(grepl(MetaPattern, allObjects) |
|
||||
grepl(ClassPattern, allObjects))]
|
||||
allMethodTables <- allObjects[grepl(MetaPattern, allObjects)]
|
||||
allClassDefs <- allObjects[grepl(ClassPattern, allObjects)]
|
||||
|
||||
## PLAIN OBJECTS and FUNCTIONS:
|
||||
funcNs <- funcPkg <- newFunc <- newNs <- newObjects <- newPkg <- objectsNs <- objectsPkg <- character()
|
||||
dependentPkgs <- list()
|
||||
|
||||
for (this in allPlainObjects) {
|
||||
thisEnv <- get(this, envir = env)
|
||||
thisNs <- NULL
|
||||
|
||||
## NS
|
||||
if (exists(this, envir = envns, inherits = FALSE)){
|
||||
thisNs <- get(this, envir = envns)
|
||||
if(is.function(thisNs) || is.function(thisEnv)){
|
||||
if(is.function(thisNs) && is.function(thisEnv)){
|
||||
if(.ess.differs(thisEnv, thisNs)){
|
||||
environment(thisEnv) <- environment(thisNs)
|
||||
.ess.assign(this, thisEnv, envns)
|
||||
funcNs <- c(funcNs, this)
|
||||
if(exists(".__S3MethodsTable__.", envir = envns, inherits = FALSE)){
|
||||
S3_table <- get(".__S3MethodsTable__.", envir = envns)
|
||||
if(exists(this, envir = S3_table, inherits = FALSE))
|
||||
.ess.assign(this, thisEnv, S3_table)
|
||||
}
|
||||
}
|
||||
}else{
|
||||
newNs <- c(newNs, this)
|
||||
}
|
||||
}else{
|
||||
if(!identical(thisEnv, thisNs)){
|
||||
.ess.assign(this, thisEnv, envns)
|
||||
objectsNs <- c(objectsNs, this)
|
||||
}
|
||||
}
|
||||
}else{
|
||||
newNs <- c(newNs, this)
|
||||
}
|
||||
|
||||
## PKG
|
||||
if (exists(this, envir = envpkg, inherits = FALSE)){
|
||||
thisPkg <- get(this, envir = envpkg)
|
||||
if(is.function(thisPkg) || is.function(thisEnv)){
|
||||
if(is.function(thisPkg) && is.function(thisEnv)){
|
||||
if(.ess.differs(thisPkg, thisEnv)){
|
||||
environment(thisEnv) <- environment(thisPkg)
|
||||
.ess.assign(this, thisEnv, envpkg)
|
||||
funcPkg <- c(funcPkg, this)
|
||||
}
|
||||
}else{
|
||||
newPkg <- c(newPkg, this)
|
||||
}
|
||||
}else{
|
||||
if(!identical(thisPkg, thisEnv)){
|
||||
.ess.assign(this, thisEnv, envpkg)
|
||||
objectsPkg <- c(objectsPkg, this)
|
||||
}
|
||||
}
|
||||
}else{
|
||||
newPkg <- c(newPkg, this)
|
||||
}
|
||||
|
||||
if (!is.null(thisNs)) {
|
||||
isDependent <- .ess.ns_propagate(thisEnv, this, importsEnvs)
|
||||
newDeps <- stats::setNames(list(packages[isDependent]), this)
|
||||
dependentPkgs <- c(dependentPkgs, newDeps)
|
||||
}
|
||||
}
|
||||
|
||||
## deal with new plain objects and functions
|
||||
for(this in intersect(newPkg, newNs)){
|
||||
thisEnv <- get(this, envir = env, inherits = FALSE)
|
||||
if(exists(this, envir = fallback_env, inherits = FALSE)){
|
||||
thisGl <- get(this, envir = fallback_env)
|
||||
if(.ess.differs(thisEnv, thisGl)){
|
||||
if(is.function(thisEnv)){
|
||||
environment(thisEnv) <- envns
|
||||
newFunc <- c(newFunc, this)
|
||||
}else{
|
||||
newObjects <- c(newObjects, this)
|
||||
}
|
||||
.ess.assign(this, thisEnv, fallback_env)
|
||||
}
|
||||
}else{
|
||||
if(is.function(thisEnv)){
|
||||
environment(thisEnv) <- envns
|
||||
newFunc <- c(newFunc, this)
|
||||
}else{
|
||||
newObjects <- c(newObjects, this)
|
||||
}
|
||||
.ess.assign(this, thisEnv, fallback_env)
|
||||
}
|
||||
}
|
||||
|
||||
if(length(funcNs))
|
||||
objectsNs <- c(objectsNs, sprintf("FUN[%s]", paste(funcNs, collapse = ", ")))
|
||||
if(length(funcPkg))
|
||||
objectsPkg <- c(objectsPkg, sprintf("FUN[%s]", paste(funcPkg, collapse = ", ")))
|
||||
if(length(newFunc))
|
||||
newObjects <- c(newObjects, sprintf("FUN[%s]", paste(newFunc, collapse = ", ")))
|
||||
|
||||
## CLASSES
|
||||
classesPkg <- classesNs <- newClasses <- character()
|
||||
for(this in allClassDefs){
|
||||
newPkg <- newNs <- FALSE
|
||||
thisEnv <- get(this, envir = env)
|
||||
if(exists(this, envir = envpkg, inherits = FALSE)){
|
||||
if(!.ess.identicalClass(thisEnv, get(this, envir = envpkg))){
|
||||
.ess.assign(this, thisEnv, envir = envpkg)
|
||||
classesPkg <- c(classesPkg, this)
|
||||
}
|
||||
}else{
|
||||
newPkg <- TRUE
|
||||
}
|
||||
if(exists(this, envir = envns, inherits = FALSE)){
|
||||
if(!.ess.identicalClass(thisEnv, get(this, envir = envns))){
|
||||
.ess.assign(this, thisEnv, envir = envns)
|
||||
classesNs <- c(classesNs, this)
|
||||
}
|
||||
}else{
|
||||
newNs <- TRUE
|
||||
}
|
||||
if(newNs && newPkg){
|
||||
if(exists(this, envir = fallback_env, inherits = FALSE)){
|
||||
if(!.ess.identicalClass(thisEnv, get(this, envir = fallback_env))){
|
||||
.ess.assign(this, thisEnv, envir = fallback_env)
|
||||
newClasses <- c(newClasses, this)
|
||||
}
|
||||
}else{
|
||||
.ess.assign(this, thisEnv, envir = fallback_env)
|
||||
newClasses <- c(newClasses, this)
|
||||
}
|
||||
}
|
||||
}
|
||||
if(length(classesPkg))
|
||||
objectsPkg <- gettextf("CLS[%s]", sub(ClassPattern, "", paste(classesPkg, collapse = ", ")))
|
||||
if(length(classesNs))
|
||||
objectsNs <- gettextf("CLS[%s]", sub(ClassPattern, "", paste(classesNs, collapse = ", ")))
|
||||
if(length(newClasses))
|
||||
newObjects <- gettextf("CLS[%s]", sub(ClassPattern, "", paste(newClasses, collapse = ", ")))
|
||||
|
||||
## METHODS:
|
||||
## Method internals: For efficiency reasons setMethod() caches
|
||||
## method definition into a global table which you can get with
|
||||
## 'getMethodsForDispatch' function, and when a method is dispatched that
|
||||
## table is used. When ess-developer is used to source method definitions the
|
||||
## two copies of the functions are identical up to the environment. The
|
||||
## environment of the cached object has namespace:foo as it's parent but the
|
||||
## environment of the object in local table is precisely namspace:foo. This
|
||||
## does not cause any difference in evaluation.
|
||||
methodNames <- allMethodTables
|
||||
methods <- sub(methods:::.TableMetaPrefix(), "", methodNames)
|
||||
methods <- sub(":.*", "", methods)
|
||||
methodsNs <- newMethods <- character()
|
||||
for (i in seq_along(methods)){
|
||||
table <- methodNames[[i]]
|
||||
tableEnv <- get(table, envir = env)
|
||||
if(exists(table, envir = envns, inherits = FALSE)){
|
||||
inserted <- .ess.ns_insertMethods(tableEnv, get(table, envir = envns), envns)
|
||||
if(length(inserted))
|
||||
methodsNs <- c(methodsNs, gettextf("%s{%s}", methods[[i]], paste(inserted, collapse = ", ")))
|
||||
}else if(exists(table, envir = fallback_env, inherits = FALSE)){
|
||||
inserted <- .ess.ns_insertMethods(tableEnv, get(table, envir = fallback_env), envns)
|
||||
if(length(inserted))
|
||||
newMethods <- c(newMethods, gettextf("%s{%s}", methods[[i]], paste(inserted, collapse = ", ")))
|
||||
}else{
|
||||
.ess.assign(table, tableEnv, envir = fallback_env)
|
||||
newMethods <- c(newMethods, gettextf("%s{%s}", methods[[i]], paste(objects(envir = tableEnv, all.names = T), collapse = ", ")))
|
||||
}
|
||||
}
|
||||
if(length(methodsNs))
|
||||
objectsNs <- c(objectsNs, gettextf("METH[%s]", paste(methodsNs, collapse = ", ")))
|
||||
if(length(newMethods))
|
||||
newObjects <- c(newObjects, gettextf("METH[%s]", paste(newMethods, collapse = ", ")))
|
||||
|
||||
if (verbose) {
|
||||
msgs <- unlist(list(
|
||||
if(length(objectsPkg))
|
||||
sprintf("PKG: %s", paste(objectsPkg, collapse = ", ")),
|
||||
if(length(objectsNs))
|
||||
sprintf("NS: %s", paste(objectsNs, collapse = ", ")),
|
||||
if(length(dependentPkgs))
|
||||
.ess.ns_format_deps(dependentPkgs),
|
||||
if(length(newObjects)) {
|
||||
env_name <- .ess.ns_env_name(fallback_env)
|
||||
sprintf("%s: %s", env_name, paste(newObjects, collapse = ", "))
|
||||
}))
|
||||
if(length(msgs))
|
||||
.ess_mpi_message(paste(msgs, collapse = " "))
|
||||
|
||||
}
|
||||
|
||||
invisible(env)
|
||||
}
|
||||
|
||||
.ess.ns_insertMethods <- function(tableEnv, tablePkg, envns) {
|
||||
inserted <- character()
|
||||
for(m in ls(envir = tableEnv, all.names = T)){
|
||||
if(exists(m, envir = tablePkg, inherits = FALSE)){
|
||||
thisEnv <- get(m, envir = tableEnv)
|
||||
thisPkg <- get(m, envir = tablePkg)
|
||||
if(is(thisEnv, "MethodDefinition") && is(thisPkg, "MethodDefinition") &&
|
||||
.ess.differs(thisEnv@.Data, thisPkg@.Data)){
|
||||
environment(thisEnv@.Data) <- envns
|
||||
## environment of cached method in getMethodsForDispatch table is still env
|
||||
## not a problem as such, but might confuse users
|
||||
.ess.assign(m, thisEnv, tablePkg)
|
||||
inserted <- c(inserted, m)
|
||||
}}}
|
||||
inserted
|
||||
}
|
||||
|
||||
## our version of R's evalSource
|
||||
.ess.ns_evalSource <- function(file, visibly, output, expr, package = "",
|
||||
fake.source = FALSE) {
|
||||
envns <- tryCatch(asNamespace(package), error = function(cond) NULL)
|
||||
if(is.null(envns))
|
||||
stop(gettextf("Package \"%s\" is not attached and no namespace found for it",
|
||||
package), domain = NA)
|
||||
env <- new.env(parent = envns)
|
||||
env[[".packageName"]] <- package
|
||||
methods:::setCacheOnAssign(env, TRUE)
|
||||
if (missing(file))
|
||||
eval(expr, envir = env)
|
||||
else if (is(file, "character"))
|
||||
for (f in file) {
|
||||
.ess.source(f, local = env, visibly = visibly,
|
||||
output = output, keep.source = TRUE,
|
||||
max.deparse.length = 300,
|
||||
fake.source = fake.source,
|
||||
message.prefix = sprintf("[%s] ", package))
|
||||
}
|
||||
else stop(gettextf("Invalid file argument: got an object of class \"%s\"",
|
||||
class(file)[[1]]), domain = NA)
|
||||
env
|
||||
}
|
||||
|
||||
.ess.assign <- function(x, value, envir) {
|
||||
## Cannot add bindings to locked environments
|
||||
exists <- exists(x, envir = envir, inherits = FALSE)
|
||||
if (exists && bindingIsLocked(x, envir)) {
|
||||
unlockBinding(x, envir)
|
||||
assign(x, value, envir = envir, inherits = FALSE)
|
||||
op <- options(warn = -1)
|
||||
on.exit(options(op))
|
||||
lockBinding(x, envir)
|
||||
} else if (exists || !environmentIsLocked(envir)) {
|
||||
assign(x, value, envir = envir, inherits = FALSE)
|
||||
} else {
|
||||
warning(sprintf("Cannot assign `%s` in locked environment", x),
|
||||
call. = FALSE)
|
||||
}
|
||||
invisible(NULL)
|
||||
}
|
||||
|
||||
.ess.identicalClass <- function(cls1, cls2, printInfo = FALSE) {
|
||||
slots1 <- slotNames(class(cls1))
|
||||
slots2 <- slotNames(class(cls2))
|
||||
if(identical(slots1, slots2)){
|
||||
vK <- grep("versionKey", slots1)
|
||||
if(length(vK))
|
||||
slots1 <- slots2 <- slots1[-vK]
|
||||
out <- sapply(slots1, function(nm) identical(slot(cls1, nm), slot(cls2, nm)))
|
||||
if(printInfo) print(out)
|
||||
all(out)
|
||||
}
|
||||
}
|
||||
|
||||
.ess.differs <- function(f1, f2) {
|
||||
if (is.function(f1) && is.function(f2)){
|
||||
!(identical(body(f1), body(f2)) && identical(args(f1), args(f2)))
|
||||
}else
|
||||
!identical(f1, f2)
|
||||
}
|
||||
|
||||
.ess.is_package <- function(envName) {
|
||||
isPkg <- identical(substring(envName, 0, 8), "package:")
|
||||
isPkg && (envName != "package:base")
|
||||
}
|
||||
|
||||
.ess.ns_propagate <- function(obj, name, importsEnvs) {
|
||||
containsObj <- vapply(importsEnvs, logical(1), FUN = function(envs) {
|
||||
name %in% names(envs)
|
||||
})
|
||||
|
||||
lapply(importsEnvs[containsObj], .ess.assign,
|
||||
x = name, value = obj)
|
||||
|
||||
containsObj
|
||||
}
|
||||
|
||||
.ess.ns_format_deps <- function(dependentPkgs) {
|
||||
pkgs <- unique(unlist(dependentPkgs, use.names = FALSE))
|
||||
|
||||
lapply(pkgs, function(pkg) {
|
||||
isDep <- vapply(dependentPkgs, function(deps) pkg %in% deps, logical(1))
|
||||
pkgDependentObjs <- names(dependentPkgs[isDep])
|
||||
sprintf("DEP:%s [%s] ", pkg, paste(pkgDependentObjs, collapse = ", "))
|
||||
})
|
||||
}
|
||||
|
||||
.ess.ns_env_name <- function(env) {
|
||||
name <- environmentName(env)
|
||||
name <-
|
||||
if (name == "") "Local"
|
||||
else if (grepl("^essenv:", name)) "NEW"
|
||||
else name
|
||||
name
|
||||
}
|
||||
|
||||
.ess.ns_insert_essenv <- function(nsenv) {
|
||||
if (is.character(nsenv))
|
||||
nsenv <- base::asNamespace(nsenv)
|
||||
stopifnot(isNamespace(nsenv))
|
||||
if (identical(nsenv, .BaseNamespaceEnv))
|
||||
return(.GlobalEnv)
|
||||
essenv_name <- sprintf("essenv:%s", environmentName(nsenv))
|
||||
nsenv_parent <- parent.env(nsenv)
|
||||
if (environmentName(nsenv_parent) == essenv_name) {
|
||||
return(nsenv_parent)
|
||||
}
|
||||
essenv <- new.env(parent = nsenv_parent)
|
||||
attr(essenv, "name") <- essenv_name
|
||||
nssym <- ".__NAMESPACE__."
|
||||
nssym_val <- get(nssym, envir = nsenv, inherits = FALSE)
|
||||
unlockBinding(nssym, nsenv)
|
||||
nsenv[[nssym]] <- NULL
|
||||
on.exit({
|
||||
nsenv[[nssym]] <- nssym_val
|
||||
lockBinding(nssym, nsenv)
|
||||
})
|
||||
parent.env(nsenv) <- essenv
|
||||
essenv
|
||||
}
|
||||
|
||||
|
||||
## Local Variables:
|
||||
## eval: (ess-set-style 'RRR t)
|
||||
## End:
|
||||
Reference in New Issue
Block a user