296 lines
14 KiB
R
296 lines
14 KiB
R
## 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)
|
|
}
|