Initial commit.

.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/.basic.R

@@ -0,0 +1,85 @@
+#### Essential functionality needed by ESS
+
+## Should work on *all* vesions of R.
+## Do not use _ in names, nor :: , nor 1L etc, as they
+## cannot be parsed in old R versions
+
+
+## loading ESSR.rda might fail, so re-assign here:
+.ess.Rversion <-
+    if( exists("getRversion", mode="function") ){
+        getRversion()
+    } else {
+        paste(R.version$major, R.version$minor, sep=".")
+ }
+
+.ess.R.has.utils <- (.ess.Rversion >= "1.9.0")
+.ess.utils.name <- paste("package",
+                         if(.ess.Rversion >= "1.9.0") "utils" else "base",
+                         sep = ":")
+
+## Instead of modern  utils::help use one that works in R 1.0.0:
+.ess.findFUN   <- get("find", .ess.utils.name)
+.ess.sourceFUN <- get("source", pos="package:base")
+.ess.helpFUN   <- get("help", envir=.GlobalEnv)# so it also works with d..tools
+
+### HELP
+.ess.help <- function(..., help.type = getOption('help_type'))
+{
+    if (.ess.Rversion > '2.10')# abbreviating 'help_type' on purpose:
+	.ess.helpFUN(..., help = help.type)
+    else # not using identical(), and working also for NULL:
+	.ess.helpFUN(..., htmlhelp = (length(help.type) && help.type=='html'))
+}
+
+.ess.getHelpAliases <- function(){
+    readrds <-
+        if(.ess.Rversion >= '2.13.0') readRDS
+        else .readRDS
+    rds.files <- paste(searchpaths(), "/help/aliases.rds", sep = "")
+    unlist(lapply(rds.files,
+                  function(f){
+                      if( file.exists(f) )
+                          try(names(readrds(f)))
+                  }),
+           use.names = FALSE)
+}
+
+### SOURCING
+.ess.eval <- function(string, echo = TRUE, print.eval = TRUE,
+                      max.deparse.length = 300,
+		      file = tempfile("ESS"),
+		      local = if (.ess.Rversion > '2.13') parent.frame() else FALSE)
+{
+    ## create FILE, put string into it. Then source.
+    ## arguments are like in source and .ess.source
+    cat(string, file = file)
+    on.exit(file.remove(file))
+    .ess.source(file, echo = echo, print.eval = print.eval,
+		max.deparse.length = max.deparse.length, local = local)
+}
+
+.ess.source <- function(file, echo = TRUE, print.eval = TRUE,
+			max.deparse.length = 300,
+			local = if (.ess.Rversion > '2.13') parent.frame() else FALSE)
+{
+    ss <- # drop 'keep.source' for older versions
+	if(.ess.Rversion >= "2.8") .ess.sourceFUN
+        else function(..., keep.source) .ess.sourceFUN(...)
+    invisible(ss(file, echo = echo, local = local, print.eval = print.eval,
+		 max.deparse.length = max.deparse.length,
+		 keep.source = TRUE)$value) ## return value for org-babel
+}
+
+if(.ess.Rversion < "1.8")
+    ## (works for "1.7.2"): bquote() was new in 1.8.0
+    bquote <- function(expr, where=parent.frame()){
+        unquote <- function(e)
+            if (is.pairlist(e)) as.pairlist(lapply(e, unquote))
+            else if (length(e) <= 1) e
+            else if (e[[1]] == as.name(".")) eval(e[[2]], where)
+            else as.call(lapply(e, unquote))
+
+        unquote(substitute(expr))
+    }
+

.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/.load.R

@@ -0,0 +1,53 @@
+## Do not use _ in names, nor :: as they cannot be parsed in old R versions
+
+## load .base.R and all other files into ESSR environment; then attach ESSR
+load.ESSR <- function(dir){
+    .source <-
+        if(any("keep.source" == names(formals(sys.source))))
+            sys.source
+        else
+            function(..., keep.source) sys.source(...)
+
+    Rver <-
+        if(exists("getRversion", mode="function")) getRversion()
+        else paste(R.version$major, R.version$minor, sep=".")
+
+    oldR <- Rver <= "1.3.0"
+
+    ESSR <-
+        if(oldR) ## really old library() revert order a bit
+            attach(NULL, name = "ESSR")
+        else if(length(nn <- names(formals(new.env))) && any(nn == "parent"))
+            new.env(parent =
+                    if(Rver >= "1.9.0") getNamespace("utils")
+                    else .BaseNamespaceEnv)
+        else
+            new.env()
+
+    assign(".ess.Rversion", Rver, envir = ESSR)
+
+    ESSRver <- scan(paste(dirname(dir), "/VERSION", sep = ""),
+                    what = "character", quiet = TRUE)
+    assign(".ess.ESSRversion", ESSRver, envir = ESSR)
+
+
+    ## .basic.R:
+    try(.source(paste(dir,'/.basic.R', sep = ""), envir = ESSR, keep.source = FALSE))
+
+    ## all others try(*) as it will fail in old R
+    if(!oldR) # no sense if(oldR)
+        for( f in dir(dir, pattern='\\.R$', full.names=TRUE) )
+            try(.source(f, envir = ESSR, keep.source = FALSE))
+
+    if(Rver >= "2.4.0")
+        attach(ESSR)
+    else if(!oldR) { ## borrow from older library()
+        e <- attach(NULL, name = "ESSR")
+        .Internal(lib.fixup(ESSR, e))
+    } else { ## if(oldR), use as in that old library():
+        .Internal(lib.fixup(ESSR, .GlobalEnv))
+    }
+
+    ## BUILDESSR needs this:
+    invisible(ESSR)
+}

.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/completion.R

@@ -0,0 +1,100 @@
+## Do *NOT* use  1L -- it gives  parse errors in historical versions of R
+
+.ess_funargs <- function(funname) {
+    if(.ess.Rversion > '2.14.1') {
+        comp <- compiler::enableJIT(0)
+        op <- options(error=NULL)
+        on.exit({ options(op); compiler::enableJIT(comp) })
+    }
+    ## don't remove; really need eval(parse(  here!!
+    fun <- tryCatch(eval(parse(text=funname)),
+                    error=function(e) NULL) ## also works for special objects containing @:$ etc
+    if(is.function(fun)) {
+        special <- grepl('[:$@[]', funname)
+        args <- if(!special){
+            fundef <- paste(funname, '.default',sep='')
+            do.call('argsAnywhere', list(fundef))
+        }
+
+        if(is.null(args))
+            args <- args(fun)
+        if(is.null(args))
+            args <- do.call('argsAnywhere', list(funname))
+
+        fmls <- formals(args)
+        fmls_names <- names(fmls)
+        fmls <- gsub('\"', '\\\"',
+                     gsub("\\", "\\\\", as.character(fmls),fixed = TRUE),
+                     fixed=TRUE)
+        args_alist <-
+            sprintf("'(%s)",
+                    paste("(\"", fmls_names, "\" . \"", fmls, "\")",
+                          sep = '', collapse = ' '))
+        allargs <-
+            if(special) fmls_names
+            else tryCatch(gsub('=', '', utils:::functionArgs(funname, ''), fixed = TRUE),
+                          error=function(e) NULL)
+        allargs <- sprintf("'(\"%s\")",
+                           paste(allargs, collapse = '\" "'))
+        envname <- environmentName(environment(fun))
+        if(envname == "R_GlobalEnv") envname <- ""
+        cat(sprintf('(list \"%s\" %s %s)\n',
+                    envname, args_alist, allargs))
+    }
+}
+
+.ess_get_completions <- function(string, end){
+    if(.ess.Rversion > '2.14.1'){
+        comp <- compiler::enableJIT(0)
+        op <- options(error=NULL)
+        on.exit({ options(op); compiler::enableJIT(comp) })
+    }
+    utils:::.assignLinebuffer(string)
+    utils:::.assignEnd(end)
+    utils:::.guessTokenFromLine()
+    utils:::.completeToken()
+    c(get('token', envir=utils:::.CompletionEnv),
+      utils:::.retrieveCompletions())
+}
+
+.ess_arg_help <- function(arg, func){
+    op <- options(error=NULL)
+    on.exit(options(op))
+    fguess <-
+        if(is.null(func)) get('fguess', envir=utils:::.CompletionEnv)
+        else func
+    findArgHelp <- function(fun, arg){
+        file <- help(fun, try.all.packages=FALSE)[[1]]
+        hlp <- utils:::.getHelpFile(file)
+        id <- grep('arguments', tools:::RdTags(hlp), fixed=TRUE)
+        if(length(id)){
+            arg_section <- hlp[[id[[1]]]]
+            items <- grep('item', tools:::RdTags(arg_section), fixed=TRUE)
+            ## cat('items:', items, fill=TRUE)
+            if(length(items)){
+                arg_section <- arg_section[items]
+                args <- unlist(lapply(arg_section,
+                                      function(el) paste(unlist(el[[1]][[1]], TRUE, FALSE), collapse='')))
+                fits <- grep(arg, args, fixed=TRUE)
+                ## cat('args', args, 'fits', fill=TRUE)
+                if(length(fits))
+                    paste(unlist(arg_section[[fits[1]]][[2]], TRUE, FALSE), collapse='')
+            }
+        }
+    }
+    funcs <- c(fguess, tryCatch(methods(fguess),
+                                warning=function(w) {NULL},
+                                error=function(e) {NULL}))
+    if(length(funcs) > 1 && length(pos <- grep('default', funcs))){
+        funcs <- c(funcs[[pos[[1]]]], funcs[-pos[[1]]])
+    }
+    i <- 1; found <- FALSE
+    out <- 'No help found'
+    while(i <= length(funcs) && is.null(out <-
+        tryCatch(findArgHelp(funcs[[i]], arg),
+                 warning=function(w) {NULL},
+                 error=function(e) {NULL})
+                                        ))
+        i <- i + 1
+    cat('\n\n', as.character(out), '\n')
+};

.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/debug.R

@@ -0,0 +1,187 @@
+
+### BREAKPOINTS
+.ESSBP. <- new.env()
+
+### DEBUG/UNDEBUG
+.ess_find_funcs <- function(env)
+    {
+        objs <- ls(envir = env, all.names = TRUE)
+        objs[sapply(objs, exists, envir = env,
+                    mode = 'function', inherits = FALSE)]
+    }
+
+.ess_all_functions <- function(packages = c(), env = NULL)
+    {
+        if(is.null(env))
+            env <- parent.frame()
+        empty <- emptyenv()
+        coll <- list()
+        for(p in packages){
+            ## package might not be attached
+            try({objNS <- .ess_find_funcs(asNamespace(p))
+                 objPKG <- .ess_find_funcs(as.environment(paste0('package:', p)))
+                 coll[[length(coll) + 1]] <-
+                     paste0(p, ':::`', setdiff(objNS, objPKG), '`')
+             }, silent = TRUE)
+        }
+        while(!identical(empty, env)){
+            coll[[length(coll) + 1]] <- .ess_find_funcs(env)
+            env <- parent.env(env)
+        }
+        grep('^\\.ess', unlist(coll, use.names = FALSE),
+             invert = TRUE, value = TRUE)
+    }
+
+.ess_dbg_getTracedAndDebugged <- function(packages = c())
+    {
+        tr_state <- tracingState(FALSE)
+        on.exit(tracingState(tr_state))
+        generics <- methods::getGenerics()
+        all_traced <- c()
+        for(i in seq_along(generics)){
+            genf <- methods::getGeneric(generics[[i]],
+                                        package=generics@package[[i]])
+            if(!is.null(genf)){ ## might happen !! v.2.13
+                menv <- methods::getMethodsForDispatch(genf)
+                traced <- unlist(eapply(menv, is, 'traceable', all.names=TRUE))
+                if(length(traced) && any(traced))
+                    all_traced <- c(paste(generics[[i]],':',
+                                          names(traced)[traced],sep=''), all_traced)
+                tfn <- getFunction(generics[[i]], mustFind=FALSE, where = .GlobalEnv)
+                if(!is.null(tfn ) && is(tfn,  'traceable')) # if the default is traced,  it does not appear in the menv :()
+                    all_traced <- c(generics[[i]], all_traced)
+            }
+        }
+        debugged_pkg <- unlist(lapply(packages, function(pkgname){
+            ns <- asNamespace(pkgname)
+            funcs <- .ess_find_funcs(ns)
+            dbged <- funcs[unlist(lapply(funcs,
+                                         function(f){
+                                             isdebugged(get(f, envir = ns, inherits = FALSE))
+                                         }))]
+            if(length(dbged))
+                paste0(pkgname, ':::`', dbged, '`')
+        }))
+        env <- parent.frame()
+        ## traced function don't appear here. Not realy needed and would affect performance.
+        all <- .ess_all_functions(packages = packages, env = env)
+        which_deb <- lapply(all, function(nm){
+            ## if isdebugged is called with string it doess find
+            tryCatch(isdebugged(get(nm, envir = env)),
+                     error = function(e) FALSE)
+            ## try(eval(substitute(isdebugged(nm), list(nm = as.name(nm)))), silent = T)
+        })
+        debugged <- all[which(unlist(which_deb, recursive=FALSE, use.names=FALSE))]
+        unique(c(debugged_pkg, debugged, all_traced))
+    }
+
+.ess_dbg_UntraceOrUndebug <- function(name, env = parent.frame())
+    {
+        tr_state <- tracingState(FALSE)
+        on.exit(tracingState(tr_state))
+        if( grepl('::', name) ){
+            ## foo:::bar name
+            eval(parse(text = sprintf('undebug(%s)', name)))
+        }else{
+            ## name is a name of a function to be undebugged or has a form
+            ## name:Class1#Class2#Class3 for traced methods
+            name <- strsplit(name, ':', fixed = TRUE)[[1]]
+            if( length(name)>1 ){
+                ## a method
+                fun <- name[[1]]
+                sig <- strsplit(paste(name[-1], collapse=''), '#', fixed=TRUE)[[1]]
+                untrace(fun, signature = sig)
+            }else{
+                ## function
+                if( is(getFunction(name, where = parent.frame()), 'traceable') )
+                    untrace(name)
+                else if(grepl(":", name))
+                    undebug(name)
+                else
+                    undebug(get(name, envir = env))
+            }}
+    }
+
+.ess_dbg_UndebugALL <- function(funcs)
+    {
+        tr_state <- tracingState(FALSE)
+        on.exit(tracingState(tr_state))
+        env <- parent.frame()
+        invisible(lapply(funcs, function( nm ) {
+            ## ugly tryCatch, but there might be several names pointing to the
+            ## same function, like foo:::bar and bar. An alternative would be
+            ## to call .ess_dbg_getTracedAndDebugged each time but that might
+            ## be ery slow
+            try(.ess_dbg_UntraceOrUndebug(nm, env = env), TRUE)
+        }))
+    }
+
+### WATCH
+.ess_watch_expressions <- list()
+
+.ess_watch_eval <- function()
+    {
+        env <- as.environment("ESSR")
+        exps <- get('.ess_watch_expressions', envir = env)
+        if(length(exps) == 0) {
+            ## using old style so this can be parsed by R 1.9.1 (e.g):
+            cat('\n# Watch list is empty!\n',
+'# a       append new expression',
+'# i       insert new expression',
+'# k       kill',
+'# e       edit the expression',
+'# r       rename',
+'# n/p     navigate',
+'# u/d,U   move the expression up/down',
+'# q       kill the buffer',
+sep="\n")
+        } else {
+            .parent_frame <- parent.frame()
+            .essWEnames <- allNames(exps)
+            len0p <- !nzchar(.essWEnames)
+            .essWEnames[len0p] <- seq_along(len0p)[len0p]
+            for(i in seq_along(exps)) {
+                cat('\n@---- ', .essWEnames[[i]], ' ',
+                    rep.int('-', max(0, 35 - nchar(.essWEnames[[i]]))), '-@\n', sep = '')
+                cat(paste('@---:', deparse(exps[[i]][[1]])), ' \n', sep = '')
+                tryCatch(print(eval(exps[[i]],
+                                    envir = .parent_frame)),
+                         error = function(e) cat('Error:', e$message, '\n' ),
+                         warning = function(w) cat('warning: ', w$message, '\n' ))
+            }
+        }
+    }
+
+.ess_watch_assign_expressions <- function(elist){
+    assign(".ess_watch_expressions", elist, envir = as.environment("ESSR"))
+}
+
+.ess_log_eval <- function(log_name)
+    {
+        env <- as.environment("ESSR")
+        if(!exists(log_name, envir = env, inherits = FALSE))
+            assign(log_name, list(), envir = env)
+        log <- get(log_name, envir = env, inherits = FALSE)
+        .essWEnames <- allNames(.ess_watch_expressions)
+        cur_log <- list()
+        .parent_frame <- parent.frame()
+        for(i in seq_along(.ess_watch_expressions)) {
+            capture.output( {
+                cur_log[[i]] <-
+                    tryCatch(eval(.ess_watch_expressions[[i]]),
+                             envir = .parent_frame,
+                             error = function(e) paste('Error:', e$message, '\n'),
+                             warning = function(w) paste('warning: ', w$message, '\n'))
+                if(is.null(cur_log[i][[1]]))
+                    cur_log[i] <- list(NULL)
+            })
+        }
+        names(cur_log) <- .essWEnames
+        assign(log_name, c(log, list(cur_log)), envir = env)
+        invisible(NULL)
+    }
+
+.ess_package_attached <- function(pack_name){
+    as.logical(match(paste0("package:", pack_name), search()))
+}
+

.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/developer.R

@@ -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)
+}

.emacs.d/elpa/ess-20160208.453/etc/ESSR/R/misc.R

@@ -0,0 +1,116 @@
+.ess_weave <- function(command, file, encoding = NULL){
+    cmd_symb <- substitute(command)
+    if(grepl('knit|purl', deparse(cmd_symb))) require(knitr)
+    od <- getwd()
+    on.exit(setwd(od))
+    setwd(dirname(file))
+    frame <- parent.frame()
+    if(is.null(encoding))
+        eval(bquote(.(cmd_symb)(.(file))), envir = frame)
+    else
+        eval(bquote(.(cmd_symb)(.(file), encoding = .(encoding))), envir = frame)
+}
+
+.ess_knit <- function(file, output = NULL){
+    library(knitr)
+    frame <- parent.frame()
+    od <- getwd()
+    on.exit(setwd(od))
+    setwd(dirname(file))
+    ## this bquote is really needed for data.table := operator to work correctly
+    eval(bquote(knit(.(file), output = .(output))), envir = frame)
+}
+
+.ess_sweave <- function(file, output = NULL){
+    od <- getwd()
+    frame <- parent.frame()
+    on.exit(setwd(od))
+    setwd(dirname(file))
+    eval(bquote(Sweave(.(file), output = .(output))), envir = frame)
+}
+
+## Users might find it useful. So don't prefix with .ess.
+htsummary <- function (x, hlength = 4, tlength = 4, digits = 3)
+{
+    ## fixme: simplify and generalize
+    snames <- c("mean", "sd", "min", "max", "nlev", "NAs")
+    d <- " "
+    num_sumr <- function(x){
+        c(f(mean(x, na.rm = TRUE)),
+          f(sd(x, na.rm = TRUE)),
+          f(min(x, na.rm = TRUE)),
+          f(max(x, na.rm = TRUE)),
+          d,
+          f(sum(is.na(x), na.rm = TRUE)))
+    }
+    f <- function(x) format(x, digits = digits)
+
+    if (is.data.frame(x) | is.matrix(x)) {
+        if (nrow(x) <= tlength + hlength){
+            print(x)
+        } else {
+            if (is.matrix(x))
+                x <- data.frame(unclass(x))
+            ## conversion needed, to avoid problems with derived classes suchs as data.table
+            h <- as.data.frame(head(x, hlength))
+            t <- as.data.frame(tail(x, tlength))
+            for (i in 1:ncol(x)) {
+                h[[i]] <- f(h[[i]])
+                t[[i]] <- f(t[[i]])
+            }
+            ## summaries
+            sumr <- sapply(x, function(c){
+                if(is.logical(c))
+                    ## treat logical as numeric; it's harmless
+                    c <- as.integer(c)
+                if(is.numeric(c))
+                    num_sumr(c)
+                else if(is.factor(c)) c(d, d, d, d, nlevels(c), sum(is.na(c)))
+                else rep.int(d, length(snames))
+            })
+            sumr <- as.data.frame(sumr)
+            row.names(sumr) <- snames
+            dots <- rep("...", ncol(x))
+            empty <- rep.int(" ", ncol(x))
+            lines <- rep.int(" ", ncol(x))
+            df <- rbind(h, ...= dots, t, `_____` = lines, sumr, ` ` = empty)
+            print(df)
+        }
+    } else {
+        cat("head(", hlength, "):\n", sep = "")
+        print(head(x, hlength))
+        if(length(x) > tlength + hlength){
+            cat("\ntail(", tlength, "):\n", sep = "")
+            print(tail(x, tlength))
+        }
+        cat("_____\n")
+        if(is.numeric(x) || is.logical(x))
+            print(structure(num_sumr(x), names = snames), quote = FALSE)
+        else if(is.factor(x)){
+            cat("NAs: ", sum(is.na(x), na.rm = TRUE), "\n")
+            cat("levels: \n")
+            print(levels(x))
+        }
+    }
+    invisible(NULL)
+}
+
+.ess_vignettes <- function(){
+    vs <- unclass(browseVignettes())
+    vs <- vs[sapply(vs, length) > 0]
+
+    mat2elist <- function(mat){
+        if(!is.null(dim(mat))){
+            apply(mat, 1, function(r)
+                  sprintf("(list \"%s\")",
+                          paste0(gsub("\"","\\\\\"",
+                                      as.vector(r[c("Title", "Dir", "PDF", "File", "R")])),
+                                 collapse = "\" \"")))
+        }
+    }
+    cat("(list \n",
+        paste0(mapply(function(el, name) sprintf("(list \"%s\"  %s)", 
+                                                 name,
+                                                 paste0(mat2elist(el), collapse = "\n")),
+                      vs, names(vs)), collapse = "\n"), ")\n")
+}