developer.R

## COMMENT ON S3 METHODS: It is not feasible and, quite frankly, a bad practice
## to check all the assigned function names for "." separator. Thus, 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)
##
## Otherwise R will call the registered (i.e. cached) S3 method instead of the
## new method that ess-developer inserted in the package environment.

.essDev.eval <- function(string, package, file = tempfile("ESSDev")){
    cat(string, file = file)
    on.exit(file.remove(file))
    .essDev_source(file,, package = package)
}

.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)
        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)}
        }
        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("GE: %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)
            w <- options("warn")
            on.exit(options(w))
            options(warn = -1)
            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)
}