public
Created

Helper functions for R

  • Download Gist
RbasicFunctions_example.r
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
#########################################
## R example functions ##
## R. Peek (rapeek@ucdavis.edu) ##
## 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')
}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.