+ Reply to Thread
Page 1 of 20 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 LastLast
Results 1 to 15 of 287

Thread: Share your functions & code

  1. #1
    ggplot2orBust
    Points: 72,900, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    User with most referrers
    trinker's Avatar
    Location
    Buffalo, NY
    Posts
    4,424
    Thanks
    1,815
    Thanked 931 Times in 812 Posts

    Share your functions & code




    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 by trinker; 06-25-2011 at 05:35 PM.

  2. The Following 5 Users Say Thank You to trinker For This Useful Post:

    Dason (06-25-2011), fit2perform (03-11-2014), ledzep (12-13-2011), quark (06-28-2011), TheEcologist (10-17-2011)

  3. #2
    ggplot2orBust
    Points: 72,900, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    User with most referrers
    trinker's Avatar
    Location
    Buffalo, NY
    Posts
    4,424
    Thanks
    1,815
    Thanked 931 Times in 812 Posts

    Re: Share your functions & code

    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 by trinker; 06-25-2011 at 09:17 PM. Reason: Code Improvement

  4. The Following User Says Thank You to trinker For This Useful Post:

    Nathan G (12-17-2012)

  5. #3
    Devorador de queso
    Points: 97,410, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    Posting AwardCommunity AwardDiscussion EnderFrequent PosterActivity Award
    Dason's Avatar
    Location
    Tampa, FL
    Posts
    12,981
    Thanks
    308
    Thanked 2,639 Times in 2,254 Posts

    Re: Share your functions & code

    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...

  6. #4
    Points: 1,493, Level: 21
    Level completed: 93%, Points required for next Level: 7

    Posts
    108
    Thanks
    11
    Thanked 7 Times in 7 Posts

    Re: Share your functions & code

    think this could go nicely with our book thread.

  7. #5
    ggplot2orBust
    Points: 72,900, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    User with most referrers
    trinker's Avatar
    Location
    Buffalo, NY
    Posts
    4,424
    Thanks
    1,815
    Thanked 931 Times in 812 Posts

    Re: Share your functions & code

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

  8. #6
    Devorador de queso
    Points: 97,410, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    Posting AwardCommunity AwardDiscussion EnderFrequent PosterActivity Award
    Dason's Avatar
    Location
    Tampa, FL
    Posts
    12,981
    Thanks
    308
    Thanked 2,639 Times in 2,254 Posts

    Re: Share your functions & code

    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.

  9. The Following User Says Thank You to Dason For This Useful Post:

    trinker (06-25-2011)

  10. #7
    Devorador de queso
    Points: 97,410, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    Posting AwardCommunity AwardDiscussion EnderFrequent PosterActivity Award
    Dason's Avatar
    Location
    Tampa, FL
    Posts
    12,981
    Thanks
    308
    Thanked 2,639 Times in 2,254 Posts

    Re: Share your functions & code

    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 by Dason; 06-28-2011 at 02:01 PM.

  11. The Following User Says Thank You to Dason For This Useful Post:

    Nathan G (12-17-2012)

  12. #8
    Super Moderator
    Points: 32,372, Level: 100
    Level completed: 0%, Points required for next Level: 0
    bugman's Avatar
    Posts
    2,255
    Thanks
    290
    Thanked 324 Times in 265 Posts

    Re: Share your functions & code

    Nice idea trinker! (love the avatar too btw )
    The earth is round: P<0.05

  13. #9
    ggplot2orBust
    Points: 72,900, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    User with most referrers
    trinker's Avatar
    Location
    Buffalo, NY
    Posts
    4,424
    Thanks
    1,815
    Thanked 931 Times in 812 Posts

    Re: Share your functions & code

    Dason,

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

  14. #10
    Devorador de queso
    Points: 97,410, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    Posting AwardCommunity AwardDiscussion EnderFrequent PosterActivity Award
    Dason's Avatar
    Location
    Tampa, FL
    Posts
    12,981
    Thanks
    308
    Thanked 2,639 Times in 2,254 Posts

    Re: Share your functions & code

    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.

  15. #11
    ggplot2orBust
    Points: 72,900, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    User with most referrers
    trinker's Avatar
    Location
    Buffalo, NY
    Posts
    4,424
    Thanks
    1,815
    Thanked 931 Times in 812 Posts

    Re: Share your functions & code

    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 by trinker; 06-28-2011 at 01:50 PM.
    "If you torture the data long enough it will eventually confess."
    -Ronald Harry Coase -

  16. The Following User Says Thank You to trinker For This Useful Post:

    Nathan G (12-17-2012)

  17. #12
    ggplot2orBust
    Points: 72,900, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    User with most referrers
    trinker's Avatar
    Location
    Buffalo, NY
    Posts
    4,424
    Thanks
    1,815
    Thanked 931 Times in 812 Posts

    Re: Share your functions & code

    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 by trinker; 07-02-2011 at 11:00 PM.
    "If you torture the data long enough it will eventually confess."
    -Ronald Harry Coase -

  18. The Following 2 Users Say Thank You to trinker For This Useful Post:

    Link (06-29-2011), Nathan G (12-17-2012)

  19. #13
    Devorador de queso
    Points: 97,410, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    Posting AwardCommunity AwardDiscussion EnderFrequent PosterActivity Award
    Dason's Avatar
    Location
    Tampa, FL
    Posts
    12,981
    Thanks
    308
    Thanked 2,639 Times in 2,254 Posts

    Re: Share your functions & code

    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.

    Spoiler:
    Last edited by Dason; 06-28-2011 at 06:58 PM.

  20. #14
    Points: 3,024, Level: 33
    Level completed: 83%, Points required for next Level: 26
    SmoothJohn's Avatar
    Location
    Edmonton, Canada
    Posts
    165
    Thanks
    11
    Thanked 12 Times in 10 Posts

    Re: Share your functions & code

    What kind of piracy be this?

  21. #15
    Devorador de queso
    Points: 97,410, Level: 100
    Level completed: 0%, Points required for next Level: 0
    Awards:
    Posting AwardCommunity AwardDiscussion EnderFrequent PosterActivity Award
    Dason's Avatar
    Location
    Tampa, FL
    Posts
    12,981
    Thanks
    308
    Thanked 2,639 Times in 2,254 Posts

    Re: Share your functions & code


    Quote Originally Posted by bryangoodrich's deleted post
    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...

+ Reply to Thread
Page 1 of 20 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 LastLast

           




Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts






Advertise on Talk Stats