Share your functions & code

trinker

ggplot2orBust
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:

1. Provide the code
2. A brief explanation
3. An example use of your function, code, operator etc.
4. Feel free to add suggestions (politely) to help others improve their code
5. Feel free to share as many as you’d like
Hopefully we see some creativity and everyone gets something when we all share. I'll go first with my next post.

Last edited:

trinker

ggplot2orBust
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)

Last edited:

Dason

Ambassador to the humans
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...

Dason

Ambassador to the humans
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

Ambassador to the humans
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)

Last edited:

trinker

ggplot2orBust
:yupason,

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

Dason

Ambassador to the humans
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

ggplot2orBust
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"))

Last edited:

trinker

ggplot2orBust
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)

Last edited:

Dason

Ambassador to the humans
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:
                             RRRRR
RRRRRR
RR  RRR
RR   RR
RR  RRR
RRRRR
RR  RR
RR   RR
RR    RR
RR     RR
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).

Last edited:

Dason

Ambassador to the humans
bryangoodrich's deleted post said:
Isn't there a tag?
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

Probably A Mammal
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

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

SmoothJohn

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

trinker

ggplot2orBust
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

Ambassador to the humans
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.