Miscellaneous Scripts

Simple Notetaking Function

When running R, your objects are saved to a file called .RData (if you so choose when you exit or execute save.image()), and your command history is saved to .Rhistory (again, if you so choose). Sometimes, however, it's nice to have a note pad to take notes on that stays in the working directory with your .RData and .Rhistory files. That's the purpose of the notes() function.

WARNING! DO NOT RUN THIS SCRIPT IN RStudio! 

notes <- function (file='.Rnotes.txt',ed=NULL) 
{
    sink(file,append=TRUE)
    cat(paste('\n',date(),'\n\n\n',sep=''))
    sink()

    sys <- Sys.info()['sysname']

    if (sys == 'Windows') {
      if (is.null(ed)) ed <- 'notepad'
      x <- paste("shell('",ed,file,"')")
    } else {
      if (is.null(ed)) ed <- 'vim + '
      x <- paste("system('",ed,file,"')")
    }
    eval(parse(text=x))
}

The notes() function opens an editor on a file from inside your running R session. The default file name is .Rnotes.txt but that can be overwritten as a command argument. The default editor depends on the operating system: in Windoze it's notepad and in linux/OSX it's vim. Again, you can use any editor you wish if you specify it as a command line argument. It inserts the time and date, and at least in linux/OSX moves the cursor to the bottom of the file (anybody have hints on how to do that in notepad?)

Simple Scripting Function

Additionally, sometimes it's convenient to edit and source a script file from inside your running R session. This is relatively easily done on most platforms, but the script below honors the R way of doing things in the console.

WARNING! DO NOT RUN THIS SCRIPT IN RStudio! 

script <- function (file=NULL,ed=NULL) 
{
    if (is.null(file)) stop('You must specify a file name.')

    sys <- Sys.info()['sysname']

    if (sys == 'Windows') {
      if (is.null(ed)) ed <- 'notepad'
      x <- paste("shell('",ed,file,"')")
    } else {
      if (is.null(ed)) ed <- 'vim'
      x <- paste("system('",ed,file,"')")
    }
    eval(parse(text=x))
    source(file)
}

There is no default file name, and one must be specified. The default editor is determined by the operating system as for notes().

Global Search and Replace for Data.Frames

Editing data.frames is sometimes a pain, especially for factors. You can't add new levels, and if you delete the last instance of a level the level itself still remains. The function below allows to you to do a global search-and-replace and finesses the problems with factors in data.frames. It works for numeric fields as well. 
gsr <- function (field,old,new)
{
    if (length(old) != length(new)) 
            stop("replacement vectors must be teh same length")
    newfield <- as.character(field)
    if (length(old)==1) {
        newfield[newfield==old] <- new
    } else {
        for (i in 1:length(old)) newfield[newfield==old[i]] <- new[i]
    }

    if (is.factor(field)) newfield <- factor(newfield)
    if (is.numeric(field)) newfield <- as.numeric(newfield)
    return(newfield)
}

Here's an example.

library(labdsv) data(brycesite) summary(brycesite$quad)
bc bp pc rp tc tr 16 81 9 3 33 18
brycesite$quad <- gsr(brycesite$quad,c('bc','bp'),c('aa','bb')) summary(brycesite$quad)
aa bb pc rp tc tr 16 81 9 3 33 18

Notice that 'bc' got converted to 'aa' and 'bp' got converted to 'bb' respectively, and that 'bc' and 'bp' no longer appear in the levels.

levels(brycesite$quad)
[1] "aa" "bb" "pc" "rp" "tc" "tr"

DSVLS

After a while you end up with a lot of objects in your work space. Even if you followed good naming practices it gets hard to keep track. The script below looks for objects that LabDSV knows about and formats the ls() accordingly. 
dsvls <- function (obj=NULL,opt='full')
{
    if (is.null(obj)) obj <- ls(parent.frame())

    df <- NULL
    dis <- NULL
    ord <- NULL
    clust <- NULL
    stride <- NULL
    ordip <- NULL
    for (i in obj) {
        tmp <- eval(parse(text=i))
        if (inherits(tmp,'data.frame')) df <- c(df,i)
        else if (inherits(tmp,'dist')) dis <- c(dis,i)
        else if (inherits(tmp,'dsvord')) ord <- c(ord,i)
        else if (inherits(tmp,c('pca','pco','nmds','fso')))  ord <- c(ord,i)
        else if (inherits(tmp,c('clustering','partition',
            'optpart','hclust'))) clust <- c(clust,i)
        else if (inherits(tmp,'stride')) stride <- c(stride,i)
        else if (inherits(tmp,'ordiplot')) ordip <- c(ordip,i)
    }
    if (opt == 'brief') {
        cat('data.frames\n')
        for (i in df) cat(paste('    ',i,'\n'))
        cat('distance/dissimilarity matrices\n')
        for (i in dis) cat(paste('    ',i,'\n'))
        cat('ordinations\n')
        for (i in ord) cat(paste('    ',i,'\n'))
        cat('classifications\n')
        for (i in clust) cat(paste('    ',i,'\n'))
        cat('strides\n')
        for (i in stride) cat(paste('    ',i,'\n'))
        cat('vegan ordiplots\n')
        for (i in ordip) cat(paste('    ',i,'\n'))
    } else {
        if (length(df) > 0) {
            cat('data.frames\n')
            for (i in df) {
                 cat(paste('    ',i,'\n'))
                 tmp <- eval(parse(text=i))
                 cat(paste('        nrow = ',nrow(tmp)),'\n')
                 cat(paste('        ncol = ',ncol(tmp)),'\n')
            }
        }
        if (length(dis) > 0) {
            cat('distance/dissimilarity matrices\n')
            for (i in dis) {
                 cat(paste('    ',i,'\n'))
                 tmp <- eval(parse(text=i))
                 if (!is.null(attr(tmp,'call'))) {
                     str <- c(attr(tmp,'call'))
                     cat(paste('        call     = ',str,'\n'))
                 }
                 cat(paste('        size     = ',attr(tmp,'Size'),'\n'))
                 if (!is.null(attr(tmp,'method')))
                      cat(paste('        method   = ',attr(tmp,'method'),'\n'))
            }
        }
        if (length(ord) > 0) {
        cat('ordinations\n')
            for (i in ord) {
                cat(paste('    ',i,'\n'))
                tmp <- eval(parse(text=i))
                cat(paste('        type  = ',tmp$type,'\n'))
                cat(paste('        dim   = ',ncol(tmp$points)),'\n')
            }
        }
        if (length(ordip) > 0) {
            cat('vegan ordiplot\n')
            for (i in ordip) {
                cat(paste('    ',i,'\n'))
                tmp <- eval(parse(text=i))
                cat(paste('        dim   = ',ncol(tmp$sites),'\n'))
            }
        }
        if (length(clust) > 0) {
        cat('classifications\n')
            for (i in clust) {
                tmp <- eval(parse(text=i))
                cat(paste('    ',i,'\n'))
                if (inherits(tmp,'hclust')) {
                    cat(paste('        dis    = ',tmp$dist.method,'\n'))
                    cat(paste('        method = ',tmp$method,'\n'))
                } else if (inherits(tmp,'partana')) {
                    cat(paste('        dis    = ',attr(tmp,'call')[[3]],'\n'))
                    cat(paste('        numclu = ',attr(tmp,'call')[[2]],'\n'))
                    cat(paste('        numitr = ',tmp$numitr,'\n'))
                    cat(paste('        ratio  = ',round(tmp$ratio[tmp$numitr],2),'\n'))
                } else if (inherits(tmp,'partition')) {
                    cat(paste('        dis    = ',tmp$call[[2]],'\n'))
                    cat(paste('        method = ',attr(tmp,'class')[[1]],'\n'))
                    cat(paste('        numclu = ',tmp$call[[3]],'\n'))
                }
            }
        }
    }
}

LabDSV ggplot Theme

set_theme_labdsv <- function()
{
    theme_labdsv <- theme_bw() +
        theme(axis.text.y = element_text(angle=90,hjust=0.5),
              plot.title=element_text(hjust=0.5))
    theme_set(theme_labdsv)
}