Share your functions & code

trinker · Jun 25, 2011

I’m starting this thread as a sharing thread. The power of [R] is in building and sharing on one another’s creativity. I’m often amazed at how people have used [R]. Anyway I’m starting this thread because I’ve been playing with special operators. I made a marginal +/- operator and thought what else could I use the %operator%<-function(){} for? Then I had an idea. What if I shared some of my creations and in return ask that you share your creations. Things we’ve made from combining other people’s stuff; could be a function, useful code snippets, or the special operator etc. Often we make these things and they’re pretty cool but we never put them into a package because we’re too lazy. So I’d like to start this sharing [R] code thread to do just that. Just some guidelines:

Hopefully we see some creativity and everyone gets something when we all share. I'll go first with my next post.

trinker · Jun 25, 2011

Add text and shapes with the mouse click (even in the margins)

TEXT CLICK:
This allows you to add text & expressions anywhere in a plot (even the margins) with a click(s) of the mouse.

Code:

textClick <- function(express, col="black", cex=NULL, srt = 0, family="sans", ...){

   old.par <- par(no.readonly = TRUE) 
   on.exit(par(old.par))

par(mar = rep(0, 4),xpd=NA)
x<-locator(1)
X<-format(x, digits=3)
text(x[1], x[2], express, col=col, cex=cex, srt=srt, family=family, ...)
noquote(paste(X[1], X[2],sep=", "))
}

SHAPE CLICK:
This allows you to add circles, boxes, cylinders, lines, segments, arrows, polygons to plots with a click(s) of the mouse.

Code:

shapeClick<-function(shape="arrow",corners=NULL,col=NULL, 
border = NULL, code=2,lty = par("lty"),length=1, lwd = par("lwd")){
par(xpd=NA)
RECTANGLE<-function(...){
coos<-c(unlist(locator(1)),unlist(locator(1)))
rect(coos[1],coos[2],coos[3],coos[4],col = col, 
border = border, lty =lty, lwd =lwd,length=NULL)
}
ARROW<-function(...){
coos<-c(unlist(locator(1)),unlist(locator(1)))
arrows(coos[1],coos[2],coos[3],coos[4],code=code,col = col, 
border = NULL, lty =lty, lwd =lwd,length=length)
}
lineSEGMENT<-function(...){
coos<-c(unlist(locator(1)),unlist(locator(1)))
segments(coos[1],coos[2],coos[3],coos[4],col = col, 
border = NULL, lty =lty, lwd =lwd,length=NULL)
}
POLYGON<-function(...){
locations<-locator(corners)
polygon(locations,col = col,
border = border, lty =lty, lwd =lwd,length=NULL)
}
CIRCLE<-function(...){
library(plotrix)
coos<-c(unlist(locator(1)),unlist(locator(1)))
rad<-sqrt(((coos[3]-coos[1])^2)+((coos[4]-coos[2])^2))
draw.circle(coos[1],coos[2],radius=rad,col = col,
border = border, lty =lty, lwd =lwd)
}
CYLINDER<-function(...){
library(plotrix)
coor<-unlist(locator(2))
cylindrect(coor[1],coor[3],coor[2],coor[4],col=col)
}
switch(shape,
box=RECTANGLE(col,border,lty,lwd),
arrow=ARROW(col,border,lty,lwd,code,length),
seg=lineSEGMENT(col,border,lty,lwd),
poly=POLYGON(col,border,lty,lwd,corners),
circle=CIRCLE(col,border,lty,lwd),
cyl=CYLINDER(col),
stop("Invalid Argumets"))
}

EXAMPLES:

Code:

frame()
textClick("Hello","red",2)
textClick("Hello","blue",.5)
textClick(expression(sum(x^2)==5^hat(x)),"blue",1)

shapeClick("arrow",col="blue",code=2,lwd=2,length=.15)
shapeClick("box",border="purple",col="pink",lwd=2)
shapeClick("box",border="purple",lwd=2)
shapeClick("seg",col="orange",lty=3,lwd=3)
shapeClick("poly",corners=5,border="green",col="orange",lty=1,lwd=3)
shapeClick("poly",corners=3,border="red",col="yellow",lty=1,lwd=2)
shapeClick("cyl",col="orange")
shapeClick("circle",col="orange",border="black",lty=3,lwd=3)

Dason · Jun 25, 2011

I like this thread. I'm going to sticky it cause it's just a good idea. I also really like your text click function. I'm not sure how often I'd use it... actually scratch that. I know how I would modify it so that I actually will use it. If you add the location that you clicked as a return it would make placing text a lot easier than the trial and error method I typically use...

I'll see if I can scrounge up a couple of useful functions I use...

interestednew · Jun 25, 2011

think this could go nicely with our book thread.

trinker · Jun 25, 2011

Dason, I liked the suggestion. I modified the text code.

Dason · Jun 25, 2011

I don't know how often it would be used but I have one more suggestion. Instead of taking col and cex as parameters into the function directly why not modify it as such:

Code:

textClick<-function(express, ...){
  par(mar = rep(0, 4), xpd=NA)
  x <- locator(1)
  X <- format(x, digits=3)
  text(x[1], x[2], express, ...)
  paste(X[1], X[2], sep=", ")
}

Then any parameter that you would want to modify in text you can.

Dason · Jun 25, 2011

These are pretty useless but they're I have fun playing with them from time to time. Pardon the code... I wrote these quite a few years ago...

Edit: I never really provided a description so I'll do that now. The following functions are just implementations of some iterated function systems. In other words if you let them run forever they converge to a fractal image. You don't need to let them run forever to see where it's going though. One thing I wanted to do was to buffer the output (which is why I created bufferedIFS). If you don't buffer the output then you have to wait for the entire picture to be created before seeing the image. If you just try to plot each point as you calculate it then it becomes unreasonably slow. So I created a function to buffer it for you - calculating a set amount (defaults to 1000 points) - plots them - then calculates more points. This way you can watch the fractals be created and not have to wait forever.

Code:

cantorset <- function(n = 1000, p = 3, add = F){
	newpoint <- function(old){
		new <- old/p
		new <- new + rbinom(1,1,.5)*(1 - 1/p)
		return(new)
	}
	if(!add){
		plot.new()
		abline(v = c(0,1))
	}
	newpnt = 0
	for(i in 1:n){
		newpnt = rbind(newpoint(newpnt[1]),newpnt)
	}
	abline(v = newpnt)
}

triangle <- function(n = 100, probLR = 1/3, probUM = 1/3, axis = T, add = F){	
	newpoint <- function(old){
		new <- old/2
		tmp <- runif(1)
		add <- c(0,0)
		if(tmp < probLR){
			add <- c(.5,0)
		}else if(tmp < (probLR + probUM)){
			add <- c(.25,.5)
		}
		new <- new + add
		return(new)
	}
	if(!add){
		plot.new()
		if(axis){
			abline(v = c(0,1))
			abline(h = c(0,1))
		}
	}	
	newpnt = matrix(c(0,0),nrow=1)	
	for(i in 1:n){
		newpnt = rbind( newpoint(newpnt[1,]),newpnt)
	}
	points(newpnt[,1],newpnt[,2],pch=".")
}

sponge <- function(n = 100, add = F){
	newpoint <- function(old){
		new <- old/3
		tmp <- runif(1)
		add <- c(0,0)
		if(tmp < 1/8){
			add <- c(1/3,0)
		}else if(tmp < 2/8){
			add <- c(2/3,0)
		}else if(tmp < 3/8){
			add <- c(0,1/3)
		}else if(tmp < 4/8){
			add <- c(2/3,1/3)
		}else if(tmp < 5/8){
			add <- c(0,2/3)
		}else if(tmp < 6/8){
			add <- c(1/3,2/3)
		}else if(tmp < 7/8){
			add <- c(2/3,2/3)
		}
		new <- new + add
		return(new)
	}	
	if(!add){
		plot.new()
		abline(v = c(0,1))
		abline(h = c(0,1))
	}	
	newpnt = matrix(c(0,0),nrow=1)	
	for(i in 1:n){
		newpnt = rbind( newpoint(newpnt[1,]),newpnt)
	}
	points(newpnt[,1],newpnt[,2],pch=".")
	
}

mapleleaf <- function(n = 100, add = F){
	newpoint <- function(old){
		new <- old
		x <- old[1]
		y <- old[2]
		pars <- double(6)
		tmp <- runif(1)
		if(tmp < 1/4){
			pars <- c(.14,.01,0,.51,-.08,-1.31)
		}else if(tmp < 2/4){
			pars <- c(.43,.52,-.45,.5,1.49,-.75)
		}else if(tmp < 3/4){
			pars <- c(.45,-.49,.47,.47,-1.62,-.74)
		}else{
			pars <- c(.49,0,0,.51,.02,1.62)
		}	
		new[1] <- pars[1]*x+pars[2]*y+pars[5]
		new[2] <- pars[3]*x+pars[4]*y+pars[6]
		return(new)
	}
	if(!add){
		plot.new()
		abline(v = c(0,1))
		abline(h = c(0,1))
	}
	newpnt = matrix(c(0,0),nrow=1)
	for(i in 1:n){
		newpnt = rbind( newpoint(newpnt[1,]),newpnt)
	}
	newpnt = (newpnt+3.5)/7
	points(newpnt[,1],newpnt[,2],pch=".")
	
}

fern <- function(n = 100, add = F){
	newpoint <- function(old){
		new <- old
		x <- old[1]
		y <- old[2]
		pars <- double(6)
		tmp <- runif(1)
		if(tmp < .01){
			pars <- c(0,0,0,.16,0,0)
		}else if(tmp < .08){
			pars <- c(.2,-.26,.23,.22,0,1.6)
		}else if(tmp < .15){
			pars <- c(-.15,.28,.26,.24,0,.44,.07)
		}else{
			pars <- c(.85,.04,-.04,.85,0,1.6)
		}	
		new[1] <- pars[1]*x+pars[2]*y+pars[5]
		new[2] <- pars[3]*x+pars[4]*y+pars[6]
		return(new)
	}
	if(!add){
		plot.new()
		abline(v = c(0,1))
		abline(h = c(0,1))
	}
	
	newpnt = matrix(c(0,0),nrow=1)
	for(i in 1:n){
		newpnt = rbind( newpoint(newpnt[1,]),newpnt)
	}

	# Fit to screen
	newpnt[,1] <- (newpnt[,1] + 3)/7
	newpnt[,2] <- (newpnt[,2])/10.3
	points(newpnt[,1],newpnt[,2],pch=".")
	
}


bufferedIFS <- function(func, total = 10000, buffer = 1000, add = F, ...){
	if(!add){
		func(buffer,...)
	}
	n <- total/buffer
	for(i in 1:n){
		func(buffer, add = T,...)
	}
}

Code:

# Examples
bufferedIFS(cantorset, 10000, 1000)
bufferedIFS(cantorset, 10000, 1000, p = 4)

bufferedIFS(triangle, 10000, 1000)
bufferedIFS(triangle, 100000, 1000, probLR = .1, probUM = 1/3)

bufferedIFS(sponge,100000,1000)
bufferedIFS(mapleleaf, 100000, 1000)
bufferedIFS(fern, 10000, 1000)
bufferedIFS(fern, 50000, 1000, add = TRUE)

bugman · Jun 25, 2011

Nice idea trinker! (love the avatar too btw

)

trinker · Jun 25, 2011

:yup

ason,

I checked out the code. My wife was watching and was pretty impressed too. See geekiness does pay off.

Dason · Jun 25, 2011

Thanks. Those images all converge to somewhat famous fractals. I had made a couple of my own that I thought looked pretty neat too but I can't seem to find that file right now.

trinker · Jun 28, 2011

Multiple Graphics Per Plot (combines x11(), par(mfrow=c()), and layout() into single function)
The following is a small but handy little function I made for creating multiple plots on a single page. It annoys me to use x11(), and layout() or par(mfrow= blah blah blah) everytime I want to create a multiplot so I wrote them both into one function that works instead of layout()or par(mfrow=c()). The input arguments are:
width,height,columns,rows,matrix=c(1,2) (the c(1,2) is default because I use multiG() for any multiple plots lay out)

Anyway here it is...

CODE FOR THE FUNCTION (SIMPLE BUT BEAUTIFUL)

Code:

multiG<-function(width,height,columns,rows,matrix=c(1,2)){
x11(width,height)
layout(matrix(c(matrix),rows, columns, byrow = TRUE))
}

EXAMPLE

Code:

library(descr);library(psych)

multiG(18,8,3,3,c(1,1,1,1,1,1,2,3,4))
        with(mtcars,histkdnc(mpg,breaks=15,main="MILES PER GALLON"))
        with(mtcars,histkdnc(cyl,breaks=15,main="CYLINDERS"))
        with(mtcars,histkdnc(hp,breaks=15,main="HORSEPOWER"))
        with(mtcars,histkdnc(drat,breaks=15,main="DRAT"))


multiG(18,10,3,4,c(1,1,1,1,1,1,2,2,3,2,2,3))
        with(mtcars,histkdnc(mpg,breaks=15))
        with(mtcars,boxplot(mpg~cyl,notch=F,ylab="MPG",border="Blue",xlab="Cylinders",main="MPG boxplot with error bars"))
        with(mtcars,plot.design(mpg~("Cylinders"=as.factor(cyl)),fun="mean"))

trinker · Jun 28, 2011

SEARCH FUNCTION
Here's another one I keep in my .First() function in the .Rprofile of my WD...

A search function. I often work with large educational data bases of 10,000+ rows and 50+ columns. I got tired of searching the data base for a categorical/numeric(especially ID codes) item that I could only rememeber part of the name/code or couldn't spell off of the top og my head by typing grep() and searching that way so I created this search() function. It doesn't require any quotation marks for variables unless the word you're searching for has a space in it (ie two word names). It is also case sensitive (which i usually keep everything lowercase so I have had no need to further refine the function). The arguments are:
search.term,dataframe,column.name

Search Function Code

Code:

Search<-function(term,dataframe,column.name){
    te<-substitute(term)
       te<-as.character(te)
   cn<-substitute(column.name)
      cn<-as.character(cn)
          HUNT<-grep(te,dataframe[,cn])
   dataframe[c(HUNT),]
}

EXAMPLES

Code:

#CREATING A FAKE DATA SET
SampDF<-data.frame("islands"=names(islands),mtcars[1:48,])

#EXAMPLES
Search(Cuba,SampDF,islands)
Search(New,SampDF,islands)
Search(Ho,SampDF,islands)
Search("Axel Heiberg",SampDF,islands)
Search(19,SampDF,mpg)

Dason · Jun 28, 2011

I realized I never provided a description of what my code did in my previous post so I edited that in. It looks like I'm adding a bunch of useless stuff to this thread because the next thing I'm posting is something I posted in a previous thread but felt like this was an appropriate place for it as well.

I can't really describe it because that ruins part of the fun. I'll post a description in white at the bottom after the code.

Code:

h=character;r=rep;a=b=h(0);p=options()$width%/%2-5;n="
";j=r(toupper(substring(mode(a),4,4)),sum(r(5:9,2)+1)-3)
k=r(5:9,2);k[4:5]=7;k=cumsum(k+1);j[k]=n;m=paste(h(1), 
h(1));s=c(0,k[-10])+1;j[c(16:17,24:26,32:33,46:47,53:55,
61:64,70:74)]=m;for(i in 1:10)a=c(a,r(m,p),j[s[i]:k[i]])
cat(c(n,a),sep=b)

This is a convoluted piece of code. The goal is to figure out what it does before running it (Not an easy task). It was written with the express purpose of masking what it does.

Description:
It prints the letter R using a whole bunch of "R"s. It will always print in the center of the console no matter how big or small you make your console.
Output:

Code:

On a standard console size the number of characters in the code is less than the number of characters required to output so I'd say it's well worth it. If you make the console width the smallest you can then the output has less characters than the code (spaces count as a character).

SmoothJohn · Jun 28, 2011

What kind of piracy be this?

Dason · Jun 28, 2011

bryangoodrich's deleted post said:

I wish. I wonder why there isn't. Maybe I'll go ask quark if we can get that in the forum feedback section...

bryangoodrich · Jun 28, 2011

It shouldn't be hard to implement. They do it over at the Math Help Forum, and it comes in really handy, especially when you have a big block of something you don't want to clog the visual space; it lets you just toggle it hidden or visible.

Dason · Jun 28, 2011

And now that we have a book club we could use it to hide any plot twists!

SmoothJohn · Jun 28, 2011

I hope I wasn't a spoiler--I certainly did not intend to be. If I did spoil, please accept my apologies.

trinker · Jun 28, 2011

Dason I'm proficient (just a smidge away from what a real statistician would describe as dangerous) with [R]. I tried to figure it out for some time; to no avail. I failed and peeked

Don't judge.

Dason · Jun 28, 2011

Haha. I wouldn't actually expect anybody to get it. Even the original version I wrote that doesn't do silly things like rename functions and use generic variable names and use convoluted ways to get the letter "R" saved isn't necessarily easy to read.

Share your functions & code

ggplot2orBust

ggplot2orBust

Ambassador to the humans

New Member

ggplot2orBust

Ambassador to the humans

Ambassador to the humans

Super Moderator

ggplot2orBust

Ambassador to the humans

ggplot2orBust

ggplot2orBust

Ambassador to the humans

New Member

Ambassador to the humans

Probably A Mammal

Ambassador to the humans

New Member

ggplot2orBust

Ambassador to the humans