emacs/lisp/ess/etc/ESSR/R/misc.R

.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.
.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(all=FALSE) {
    vs <- unclass(browseVignettes(all = all))
    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")
}

.ess_Rd2txt <- function(rd) {
    fun <- tools::Rd2txt
    if (length(formals(fun)["stages"]))# newer R version
        fun(rd, stages = c("build", "install", "render"))
    else
        fun(rd)
}

## Hacked help.start() to use with ess-rutils.el
.ess_help_start <- function(update=FALSE, remote=NULL) {
    home <- if (is.null(remote)) {
                port <- tools::startDynamicHelp(NA)
                if (port > 0L) {
                    if (update)
                        make.packages.html(temp=TRUE)
                    paste0("http://127.0.0.1:", port)
                }
                else stop(".ess_help_start() requires the HTTP server to be running",
                          call.=FALSE)
            } else remote
    paste0(home, "/doc/html/index.html")
}


.ess.rdired <- function() {
    cat('\n')

    objs <- ls(envir = .GlobalEnv)
    if (length(objs)==0) {
        cat("No objects to view!\n")
        return(invisible(NULL))
    }

    names(objs) <- objs
    objs <- lapply(objs, get, envir = .GlobalEnv)

    mode <- sapply(objs, data.class)
    length <- sapply(objs, length)
    size <- sapply(objs, function(obj) format(object.size(obj)))
    d <- data.frame(mode, length, size)
    
    var.names <- row.names(d)
    
    ## If any names contain spaces, we need to quote around them.
    quotes <- rep('', length(var.names))
    spaces <- grep(' ', var.names)
    if (any(spaces))
        quotes[spaces] <- '\"'
    var.names <- paste(quotes, var.names, quotes, sep = '')
    row.names(d) <- paste('  ', var.names, sep = '')

    print(d)
}