Initial commit.
This commit is contained in:
295
.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/developer.R
Normal file
295
.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/developer.R
Normal file
@@ -0,0 +1,295 @@
|
||||
## COMMENT 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 .essDev_source
|
||||
.essDev.eval <- function(string, package, file = tempfile("ESSDev")){
|
||||
cat(string, file = file)
|
||||
on.exit(file.remove(file))
|
||||
.essDev_source(file,, package = package)
|
||||
}
|
||||
|
||||
## sourcing 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. .
|
||||
.essDev_source <- function(source, expr, package = "")
|
||||
{
|
||||
## require('methods')
|
||||
oldopts <- options(warn = 1)
|
||||
on.exit(options(oldopts))
|
||||
MPattern <- methods:::.TableMetaPattern()
|
||||
CPattern <- methods:::.ClassMetaPattern()
|
||||
allPlainObjects <- function() allObjects[!(grepl(MPattern, allObjects) |
|
||||
grepl(CPattern, allObjects))]
|
||||
allMethodTables <- function() allObjects[grepl(MPattern, allObjects)]
|
||||
allClassDefs <- function() allObjects[grepl(CPattern, allObjects)]
|
||||
pname <- paste("package:", package, sep = "")
|
||||
envpkg <- tryCatch(as.environment(pname), error = function(cond) NULL)
|
||||
if(is.null(envpkg)){
|
||||
library(package, character.only = TRUE)
|
||||
envpkg <- tryCatch(as.environment(pname), error = function(cond) NULL)
|
||||
}
|
||||
if (is.null(envpkg))
|
||||
stop(gettextf("Can't find an environment corresponding to package name '%s'",
|
||||
package), domain = NA)
|
||||
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)
|
||||
|
||||
## evaluate the SOURCE into new ENV
|
||||
env <- .essDev_evalSource(source, substitute(expr), package)
|
||||
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)
|
||||
|
||||
allObjects <- objects(envir = env, all.names = TRUE)
|
||||
allObjects <- allObjects[!(allObjects %in% c(".cacheOnAssign", ".packageName"))]
|
||||
|
||||
## PLAIN OBJECTS and FUNCTIONS:
|
||||
funcNs <- funcPkg <- newFunc <- newNs <- newObjects <- newPkg <- objectsNs <- objectsPkg <- character()
|
||||
|
||||
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(.essDev_differs(thisEnv, thisNs)){
|
||||
environment(thisEnv) <- environment(thisNs)
|
||||
.essDev_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))
|
||||
.essDev_assign(this, thisEnv, S3_table)
|
||||
}
|
||||
}
|
||||
}else{
|
||||
newNs <- c(newNs, this)
|
||||
}
|
||||
}else{
|
||||
if(!identical(thisEnv, thisNs)){
|
||||
.essDev_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(.essDev_differs(thisPkg, thisEnv)){
|
||||
environment(thisEnv) <- environment(thisPkg)
|
||||
.essDev_assign(this, thisEnv, envpkg)
|
||||
funcPkg <- c(funcPkg, this)}
|
||||
}else{
|
||||
newPkg <- c(newPkg, this)}
|
||||
}else{
|
||||
if(!identical(thisPkg, thisEnv)){
|
||||
.essDev_assign(this, thisEnv, envpkg)
|
||||
objectsPkg <- c(objectsPkg, this)}}
|
||||
}else{
|
||||
newPkg <- c(newPkg, this)}
|
||||
}
|
||||
|
||||
## deal with new plain objects and functions
|
||||
for(this in intersect(newPkg, newNs)){
|
||||
thisEnv <- get(this, envir = env, inherits = FALSE)
|
||||
if(exists(this, envir = .GlobalEnv, inherits = FALSE)){
|
||||
thisGl <- get(this, envir = .GlobalEnv)
|
||||
if(.essDev_differs(thisEnv, thisGl)){
|
||||
if(is.function(thisEnv)){
|
||||
environment(thisEnv) <- envns
|
||||
newFunc <- c(newFunc, this)
|
||||
}else{
|
||||
newObjects <- c(newObjects, this)
|
||||
}
|
||||
.essDev_assign(this, thisEnv, .GlobalEnv)
|
||||
}
|
||||
}else{
|
||||
if(is.function(thisEnv)){
|
||||
environment(thisEnv) <- envns
|
||||
newFunc <- c(newFunc, this)
|
||||
}else{
|
||||
newObjects <- c(newObjects, this)
|
||||
}
|
||||
.essDev_assign(this, thisEnv, .GlobalEnv)
|
||||
}
|
||||
}
|
||||
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(!.essDev_identicalClass(thisEnv, get(this, envir = envpkg))){
|
||||
.essDev_assign(this, thisEnv, envir = envpkg)
|
||||
classesPkg <- c(classesPkg, this)
|
||||
}
|
||||
}else{
|
||||
newPkg <- TRUE
|
||||
}
|
||||
if(exists(this, envir = envns, inherits = FALSE)){
|
||||
if(!.essDev_identicalClass(thisEnv, get(this, envir = envns))){
|
||||
.essDev_assign(this, thisEnv, envir = envns)
|
||||
classesNs <- c(classesNs, this)
|
||||
}
|
||||
}else{
|
||||
newNs <- TRUE
|
||||
}
|
||||
if(newNs && newPkg){
|
||||
if(exists(this, envir = .GlobalEnv, inherits = FALSE)){
|
||||
if(!.essDev_identicalClass(thisEnv, get(this, envir = .GlobalEnv))){
|
||||
.essDev_assign(this, thisEnv, envir = .GlobalEnv)
|
||||
newClasses <- c(newClasses, this)
|
||||
}
|
||||
}else{
|
||||
.essDev_assign(this, thisEnv, envir = .GlobalEnv)
|
||||
newClasses <- c(newClasses, this)
|
||||
}
|
||||
}
|
||||
}
|
||||
if(length(classesPkg))
|
||||
objectsPkg <- gettextf("CLS[%s]", sub(methods:::.ClassMetaPattern(), "", paste(classesPkg, collapse = ", ")))
|
||||
if(length(classesNs))
|
||||
objectsNs <- gettextf("CLS[%s]", sub(methods:::.ClassMetaPattern(), "", paste(classesNs, collapse = ", ")))
|
||||
if(length(newClasses))
|
||||
newObjects <- gettextf("CLS[%s]", sub(methods:::.ClassMetaPattern(), "", 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 <- .essDev_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 = .GlobalEnv, inherits = FALSE)){
|
||||
inserted <- .essDev_insertMethods(tableEnv, get(table, envir = .GlobalEnv), envns)
|
||||
if(length(inserted))
|
||||
newMethods <- c(newMethods, gettextf("%s{%s}", methods[[i]], paste(inserted, collapse = ", ")))
|
||||
}else{
|
||||
.essDev_assign(table, tableEnv, envir = .GlobalEnv)
|
||||
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(length(objectsPkg))
|
||||
cat(sprintf("%s PKG: %s ", package, paste(objectsPkg, collapse = ", ")))
|
||||
if(length(objectsNs))
|
||||
cat(sprintf("NS: %s ", paste(objectsNs, collapse = ", ")))
|
||||
if(length(newObjects))
|
||||
cat(sprintf("GlobalEnv: %s\n", paste(newObjects, collapse = ", ")))
|
||||
if(length(c(objectsNs, objectsPkg, newObjects)) == 0)
|
||||
cat(sprintf("*** Nothing explicitly assigned ***\n"))
|
||||
invisible(env)
|
||||
}
|
||||
|
||||
.essDev_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") &&
|
||||
.essDev_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
|
||||
.essDev_assign(m, thisEnv, tablePkg)
|
||||
inserted <- c(inserted, m)
|
||||
}}}
|
||||
inserted
|
||||
}
|
||||
|
||||
|
||||
.essDev_evalSource <- function (source, expr, package = "")
|
||||
{
|
||||
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(source))
|
||||
eval(expr, envir = env)
|
||||
else if (is(source, "character"))
|
||||
for (text in source) sys.source(text, envir = env, keep.source = TRUE)
|
||||
else stop(gettextf("Invalid source argument: got an object of class \"%s\"",
|
||||
class(source)[[1]]), domain = NA)
|
||||
env
|
||||
}
|
||||
|
||||
|
||||
.essDev_assign <- function (x, value, envir)
|
||||
{
|
||||
if (exists(x, envir = envir, inherits = FALSE) && 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 {
|
||||
assign(x, value, envir = envir, inherits = FALSE)
|
||||
}
|
||||
invisible(NULL)
|
||||
}
|
||||
|
||||
.essDev_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)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
.essDev_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)
|
||||
}
|
||||
Reference in New Issue
Block a user