R/specialfuns.R

#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/

### Jakson Alves de Aquino

nvim.primitive.args <- function(x)
{
    fun <- get(x)
    f <- capture.output(args(x))
    f <- sub(") $", "", sub("^function \\(", "", f[1]))
    f <- strsplit(f, ",")[[1]]
    f <- sub("^ ", "", f)
    f <- sub(" = ", "\x07", f)
    paste(f, collapse = "\x09")
}


# Adapted from: https://stat.ethz.ch/pipermail/ess-help/2011-March/006791.html
nvim.args <- function(funcname, txt, pkg = NULL, objclass, firstLibArg = FALSE)
{
    # First argument of either library() or require():
    if(firstLibArg){
        p <- dir(.libPaths())
        p <- p[grep(paste0("^", txt), p)]
        return(paste0(p, collapse = "\x09"))
    }

    frm <- NA
    funcmeth <- NA
    if(!missing(objclass) && nvim.grepl("[[:punct:]]", funcname) == FALSE){
        if(length(grep(funcname, names(.knownS3Generics))) > 0){
            for(i in 1:length(objclass)){
                funcmeth <- paste(funcname, ".", objclass[i], sep = "")
                if(existsFunction(funcmeth)){
                    funcname <- funcmeth
                    frm <- formals(funcmeth)
                    break
                }
            }
        }
    }

    if(is.na(frm[1])){
        if(is.null(pkg)){
            deffun <- paste(funcname, ".default", sep = "")
            if (existsFunction(deffun)) {
                funcname <- deffun
                funcmeth <- deffun
            } else if(!existsFunction(funcname)) {
                return("NOT_EXISTS")
            }
            if(is.primitive(get(funcname)))
                return(nvim.primitive.args(funcname))
            else
                frm <- formals(funcname)
        } else {
            idx <- grep(paste(":", pkg, "$", sep = ""), search())
            ff <- "NULL"
            tr <- try(ff <- get(paste(funcname, ".default", sep = ""), pos = idx), silent = TRUE)
            if(class(tr)[1] == "try-error")
                ff <- get(funcname, pos = idx)
            frm <- formals(ff)
        }
    }

    res <- NULL
    for (field in names(frm)) {
        type <- typeof(frm[[field]])
        if (type == 'symbol') {
            res <- append(res, paste('\x09', field, sep = ''))
        } else if (type == 'character') {
            res <- append(res, paste('\x09', field, '\x07"', frm[[field]], '"', sep = ''))
        } else if (type == 'logical') {
            res <- append(res, paste('\x09', field, '\x07', as.character(frm[[field]]), sep = ''))
        } else if (type == 'double') {
            res <- append(res, paste('\x09', field, '\x07', as.character(frm[[field]]), sep = ''))
        } else if (type == 'NULL') {
            res <- append(res, paste('\x09', field, '\x07', 'NULL', sep = ''))
        } else if (type == 'language') {
            res <- append(res, paste('\x09', field, '\x07', deparse(frm[[field]]), sep = ''))
        }
    }
    idx <- grep(paste("^\x09", txt, sep = ""), res)
    res <- res[idx]
    res <- paste(res, sep = '', collapse='')
    res <- sub("^\x09", "", res)
    res <- gsub("\n", "\\\\n", res)

    if(length(res) == 0 || res == ""){
        res <- "NO_ARGS"
    } else {
        if(is.null(pkg)){
            info <- ""
            pkgname <- find(funcname, mode = "function")
            if(length(pkgname) > 1)
                info <- pkgname[1]
            if(!is.na(funcmeth)){
                if(info != "")
                    info <- paste(info, ", ", sep = "")
                info <- paste(info, "function:", funcmeth, "()", sep = "")
            }
            if(info != "")
                res <- paste(res, "\x04", info, sep = "")
        }
    }

    return(res)
}


nvim.list.args <- function(ff){
    # The code to get the list of generic methods added manually is:
    # x <- c(names(.knownS3Generics), .S3PrimitiveGenerics, tools:::.get_internal_S3_generics())
    # x <- x[!duplicated(x)]
    # y <- c(names(.knownS3Generics), .S3PrimitiveGenerics)
    # rpt <- x %in% y
    # x <- x[!rpt]
    # dput(x)
    knownGenerics <- c(names(.knownS3Generics), .S3PrimitiveGenerics,
                       "unlist", "abs", "sign", "sqrt", "floor", "ceiling",
                       "trunc", "round", "signif", "exp", "log", "expm1",
                       "log1p", "cos", "sin", "tan", "acos", "asin", "atan",
                       "cosh", "sinh", "tanh", "acosh", "asinh", "atanh",
                       "lgamma", "gamma", "digamma", "trigamma", "cumsum",
                       "cumprod", "cummax", "cummin", "all", "any", "sum",
                       "prod", "max", "min", "range", "Arg", "Conj", "Im",
                       "Mod", "Re")

    keyf <- paste("^", ff, "$", sep="")
    is.generic <- (length(grep(keyf, knownGenerics)) > 0)
    if(is.generic){
        mm <- methods(ff)
        l <- length(mm)
        if(l > 0){
            for(i in 1:l){
                if(exists(mm[i])){
                    cat(ff, "[method ", mm[i], "]:\n", sep="")
                    print(args(mm[i]))
                    cat("\n")
                }
            }
            return(invisible(NULL))
        }
    }
    print(args(ff))
}


nvim.plot <- function(x)
{
    xname <- deparse(substitute(x))
    if(length(grep("numeric", class(x))) > 0 || length(grep("integer", class(x))) > 0){
        oldpar <- par(no.readonly = TRUE)
        par(mfrow = c(2, 1))
        hist(x, col = "lightgray", main = paste("Histogram of", xname), xlab = xname)
        boxplot(x, main = paste("Boxplot of", xname),
                col = "lightgray", horizontal = TRUE)
        par(oldpar)
    } else {
        plot(x)
    }
}

nvim.names <- function(x)
{
    if(isS4(x))
        slotNames(x)
    else
        names(x)
}

nvim.getclass <- function(x)
{
    if(getOption("nvimcom.verbose") < 3){
        saved.warn <- getOption("warn")
        options(warn = -1)
        on.exit(options(warn = saved.warn))
        tr <- try(obj <- eval(expression(x)), silent = TRUE)
    } else {
        tr <- try(obj <- eval(expression(x)))
    }
    if(class(tr)[1] == "try-error"){
        return("Error evaluating the object")
    } else {
        return(class(obj)[1])
    }
}
jalvesaq/nvimcom documentation built on May 18, 2019, 11:19 a.m.