Helper functions for R

RbasicFunctions_example.r

#########################################
## R example functions 		       ##
## R. Peek ([email protected])        ##
## 11-02-2012                          ##

print.functions <- function(){
	cat("Rounding etc.:\n",sep="")
	cat("---------\n",sep="")
	cat("roundup(x, numdigits=0) - correct rounding of .5 etc.\n",sep="")
	cat("round.largest(x) - round to largest digit, i.e., 54 -> 50 \n",sep="")
	cat("ceiling.largest(x) - ceiling to largest digit, i.e., 54 -> 60\n",sep="")
	
	cat("Standard errors, error bars, rmsd etc:\n",sep="")
	cat("--------------------------------------\n",sep="")
	cat("se(x) - standard error\n",sep="")
	cat("rmsd(x) - root mean squared deviation\n",sep="")
	cat("errbar(x,y,error,color=black) - plot error bars on (x,y)\n",sep="")
	cat("runmean(x,window) - running average of x with window, returns same length as x, with smoothed end points\n",sep="")
	
	cat("Misc.:\n",sep="")
	cat("--------\n",sep="")
	cat("C.Var(x) - calc coefficient of variation around the mean\n",sep="")
	cat("rm.levels(factor) - remove non-used levels from factor\n",sep="")
	cat("h(x,...) - shortcut for head(x,...), see ?head\n",sep="")
	cat("last(x) - get last element of vector, list, data.frame, etc.\n",sep="")
	cat("format.hrs.min.sec(seconds) - return hrs:min:sec or min:sec if sec < 3600\n",sep="")
	cat("describe(x) - an alternative to summary of numeric vector or list\n",sep="")
	cat("instant_pkgs(c(pkg)) - instant packages for multiple package install\n",sep="")
	cat(".repath() - replace / in path to \\ and copy to clipboard\n",sep="")
	
}

## Rounding etc.
##########################################################################################

#correct rounding of .5 etc.
roundup <- function(x,numdigits=0){
	x <- x * 10^numdigits
	x <- ifelse(x<0,-trunc(abs(x)+0.5),trunc(x+0.5))
	x / 10^numdigits
}

#round to largest 10's
round.largest <- function(x){
	x <- roundup(x)
	y <- 10^(nchar(as.character(x))-1)
	roundup(x / y) * y
}

#ceiling to largest 10's
ceiling.largest <- function(x){
	x <- roundup(x)
	y <- 10^(nchar(as.character(x))-1)
	ceiling(x / y) * y
}


## Standard errors, error bars, rmsd etc:
##########################################################################################

#rmsd
rmsd <- function(data,model){
	sqrt(mean((data - model)^2))	
}

#standard error
se <- function(x){
	sd(x)/sqrt(length(x))
}

#draw error bars
errbar <- function(x,y,error,color="black"){
	arrows(x,y-error,x,y+error,angle=90,length=.05,code=3,col=color) 
}

#rolmean with smooth function
runmean <- function(x,window){
	require(zoo)
	ori <- x
	new <- rollmean(x,window,na.pad=T)
	new[is.na(new)] <- ori[is.na(new)]
	new <- smoothEnds(new,window)
	new
}

## Misc
##########################################################################################

#C.Var(x) - calc coefficient of variation around the mean
C.Var <- function(x) ( 100*sd(x)/mean(x) )

#rm.levels(factor) - remove non-used levels from factor\n",sep="")
rm.levels <- function(factor){
	as.factor(as.character(factor))
}

#shortcut for head: see ?head
h <- function(data, ...){
	head(data, ...)
}

#get last element of list, vector, etc
last <- function(x){
	x[length(x)]
}

#aggregate with 'naming the x'
agg <- function(x,index,fun,name="x"){
	tmp <- aggregate(x,index,fun)
	names(tmp)[ncol(tmp)] <- name
	tmp
}

#get hrs:min:sec from seconds
format.hrs.min.sec <- function(seconds){
	minutes <- seconds / 60
	if(minutes >= 60){
		hrs <- trunc(seconds / 3600)
		paste(hrs,":",sprintf("%02.0f",trunc(minutes) - (60*hrs),2),":",sprintf("%02.0f",roundup((minutes - trunc(minutes)) * 60,2)),sep="")
	}else{
		paste(trunc(minutes),":",sprintf("%02.0f",roundup((minutes - trunc(minutes)) * 60,2)),sep="")
	}
}

#an alternative to summary of numeric vector or list
describe <- function(x){
    m=mean(x,na.rm=T)
    s=sd(x,na.rm=T)
    N=sum(is.na(x))
    n=length(x)-N
    se=s/sqrt(n)
    out=c(m,s,se,n,N)
    names(out)=c("mean","sd","sem","n","NAs")
    round(out,4)
}

#instant packages for multiple package install
 instant_pkgs <- function(pkgs) { 
    pkgs_miss <- pkgs[which(!pkgs %in% installed.packages()[, 1])]
    if (length(pkgs_miss) > 0) {
        install.packages(pkgs_miss)
    }
    
	if (length(pkgs_miss) == 0) {
	message("\n ...Packages were already installed!\n")
	}

    # install packages not already loaded:
    pkgs_miss <- pkgs[which(!pkgs %in% installed.packages()[, 1])]
    if (length(pkgs_miss) > 0) {
        install.packages(pkgs_miss)
    }
    
    # load packages not already loaded:
    attached <- search()
    attached_pkgs <- attached[grepl("package", attached)]
    need_to_attach <- pkgs[which(!pkgs %in% gsub("package:", "", attached_pkgs))]
    
    if (length(need_to_attach) > 0) {
      for (i in 1:length(need_to_attach)) require(need_to_attach[i], character.only = TRUE)
    }

	if (length(need_to_attach) == 0) {
	message("\n ...Packages were already loaded!\n")
	}
}

#Function to replace / in path to \\ and copy to clipboard
.repath <- function() {
   cat('Paste windows file path and hit RETURN twice')
   x <- scan(what = "")
   xa <- gsub('\\\\', '/', x)
   writeClipboard(paste(xa, collapse=" "))
   cat('Here\'s your de-windowsified path. (It\'s also on the clipboard.)\n', xa, '\n')
 }