Share your functions & code

Lazar

Lazar

Phineas Packard
#203
#203
Ok this is weird. It just works for me. I am going to claim that I knew about Dason's seeInternet2 thing but honestly I am not sure why it worked for me.

P.S. Want to try the log log scale now. Hurrying away to try this.
 
trinker

trinker

ggplot2orBust
#205
#205
@jimmy that's actually a really good way to:

a) become a little dorkier
b) extend your skills

When I made an R hangman game I learned a ton though I haven't really played it since :) but the learning remains.
 
trinker

trinker

ggplot2orBust
#206
#206
May I suggest R in Action. I really like this a lot as a new to intermediate book in R. The same author (Kabacoff; great guy) also does the Quick R web site (LINK). We also have a thread on here on R =resources that may be helpful (LINK).
 
Dason

Dason

Ambassador to the humans
#207
#207
Ever wished R was 0 indexed instead of 1 indexed?

Code: 
"[" <- function(x, y){base::`[`(x, y+1)}
"[<-" <- function(x, i, value){base::`[<-`(x, i+1, value)}
Which results in

Code: 
> x <- rnorm(5)
> x
[1]  1.0696787  0.9464659 -0.3197787 -0.4608032  1.0657153
> x[0]
[1] 1.069679
> x[0] <- 1
> x
[1]  1.0000000  0.9464659 -0.3197787 -0.4608032  1.0657153
Note: For the love of God don't ever do this. Plus it breaks really easily. For instance you can't use double indexing on matrices or dataframes - I haven'te quite worked out how to write over the double indexing function...
 
derksheng

derksheng

New Member
#208
#208
Function for efficiently creating headings when you're working on a big project.
Code: 
h <- function(char,type=c(1,2,3)){

	if(type==1){
		writeClipboard(paste("#%-------------#",toupper(char),"#-------------%#"))
	}
	
	if(type==2){
		writeClipboard(paste("#------#",char,"#------#"))
	}
	
	if(type==3){
		writeClipboard(paste("#---",char,"---#"))
	}

}
E.G.
1) Type h("main heading",1) into R
2) Press CTRL+V
 
Last edited:
derksheng

derksheng

New Member
#209
#209
If you use the above for your headings and subheadings in a project, you can use this function to automatically create an index to go into the preamble of your code (to assist co-authors in browsing code, and helping you navigate massive projects). Filename is the name of your code file, e.g. "quantileproject.r".

Code: 
indexcreation <- function(filename){
	con <- file(filename,"r",blocking=FALSE)
	file <- readLines(con)
	
	loc1 <- grep("#%-------------#",file,fixed=TRUE)
	loc2 <- grep("#------#",file,fixed=TRUE)
	loc3 <- grep("#--- ",file,fixed=TRUE)
	
	names1 <- file[loc1]
	names2 <- file[loc2]
	names3 <- file[loc3]
	
	names1 <- sapply(seq(length(loc1)),function(i) { strsplit(names1," ")[[i]][2] })
	names2 <- sapply(seq(length(loc2)),function(i) { strsplit(names2," ")[[i]][2] })
	names3 <- sapply(seq(length(loc3)),function(i) { strsplit(names3," ")[[i]][2] })
	
	names <- list(names1,names2,names3)
	linenumber <- list(loc1,loc2,loc3)
	
	numberdots <- unlist(sapply(1:length(linenumber),function(i) { rep(length(linenumber)+1-i,length(linenumber[[i]]))*3 }))
	numberdots <- sapply(seq(unlist(linenumber)),function(i) { numberdots[i] - length(strsplit(as.character(unlist(linenumber)[i]),"")[[1]]) })
	dots <- sapply(1:length(numberdots),function(i) { paste(rep(".",numberdots[i]),collapse="") })
		
	index <- sapply(seq(length(unlist(linenumber))),function(i) { paste(unlist(linenumber)[i],dots[i],unlist(names)[i],sep="") })
		
	locations <- unlist(linenumber)
	locations <- match(sort(locations),locations)
	index <- unlist(index)[locations]
	writeClipboard(matrix(index))
}
Just run the function then CTRL+V into your txt file's preamble.
 
trinker

trinker

ggplot2orBust
#210
#210
When I want to provide a reproducible example I like to provide the data.frame I'm using in structure format as it minimizes the typing of those helping. It can be annoying to use dput to do this in that you have to cut and paste from the console. Here's a dput2 that copies the text to the users clipboard (if mac or windows user) and places the dataframe name and arrow operator in front as well as indenting rows 2:n.

Code: 
dput2 <- function(x, indents = 4) {
    z <- capture.output(dput(x))
    y <- as.character(substitute(x))
    y <- y[length(y)]
    z[1] <- paste(y, "<-", z[1])
    z[-1] <- paste0(paste(rep(" ", indents), collapse=""), z[-1])
    zz <- as.matrix(as.data.frame(z))
    dimnames(zz) <- list(c(rep("", nrow(zz))), c(""))
    if (Sys.info()["sysname"] == "Windows") {
        writeClipboard(z, format = 1)
    }
    if (Sys.info()["sysname"] == "Darwin") {           
        j <- pipe("pbcopy", "w")                       
        writeLines(z, con = j)                               
        close(j)                                    
    }  
    noquote(zz)   
}

#try it:
dput2(mtcars)
dput2(head(mtcars))
 
Dason

Dason

Ambassador to the humans
#211
#211
I think you meant to put dput2 and not repex.

And this isn't working for me!
Code: 
dput2(mtcars + 2)
Of course I'm just being facetious but I had to find a way to break your function ;)
 
trinker

trinker

ggplot2orBust
#212
#212
Yeah dason it was supposed to be dput2, originally it was repex for reproducible example but I couldn't remember the name for the function. And yes I knew it was fairly simple to break as I used:

Code: 
dput2(head(head(mtcars, 20)))
but generally I want to dput a dataframe or the head of a dataframe. Anything else it works but you'll have to rename the object it's being assigned to. I don't really have any work around for all the different scenerios that could break it but if anyone has an easy solution I'm all eyes.
 
Dason

Dason

Ambassador to the humans
#213
#213
I doubt there is a direct solution. Consider
Code: 
val <- 10
dput2(head(mtcars, val))
How should it know which variable you want the name to be? You aren't dputting either object directly so there is no clear way to tell.
 
trinker

trinker

ggplot2orBust
#214
#214
an alternative would be to just use dat as the object we assign to since you're likely making a reproducible example anyway. What are your thoughts on that?
 
trinker

trinker

ggplot2orBust
#216
#216
Thought I'd share this one cause it's simple and has the possibility for lots of applications. outer is pretty nice but it doesn't take vectors. I once asked at SO how to make outer work with vectors and got two responses (LINK). I recieved two great responses but have stuck with the Vectorize solution though it's slower because it is more readable to me. Anyway this v.outer is a vectorized version of outer that you can supply a function to and that functions arguments. Acts on a matrix or data.frame.

Code: 
v.outer <- 
function(x, FUN, digits = 3, ...){
    FUN <- match.fun(FUN)
    if (is.matrix(x)) {
        x <- as.data.frame(x)
    }
    if (is.list(x) & !is.data.frame(x)){
        if (is.null(names(x))) {
            names(x) <- paste0("X", seq_along(x))
        }
        nms <- names(x)   
    } else {
        nms <- colnames(x)
    }
    z <- outer(
      nms, 
      nms, 
      Vectorize(function(i,j) FUN(unlist(x[[i]]), unlist(x[[j]]), ...))
    )
    dimnames(z) <- list(nms, nms)
    if (is.numeric(z)) {
        z <- round(z, digits = digits)
    }
    z
}

v.outer(mtcars, cor)
v.outer(mtcars, cor, method="kendall")
 
trinker

trinker

ggplot2orBust
#217
#217
ps I realize cor is a lttle silly in that it already gives you this output but it was the first function that came to mind that takes an x and y vector and so I used it. here's an example with a function for pooled sd (again this is a bit silly in that you'd do pooled for all and the function for pooled may be incorrect) but it can help people understand more:

Code: 
pooled.sd <- function(x, y) {
    n1 <- length(x)
    n2 <- length(y)
    s1 <- sd(x)
    s2 <- sd(y)
    sqrt(((n1-1)*s1 + (n2-1)*s2)/((n1-1) + (n2-1)))
}

v.outer(mtcars, pooled.sd)
PS can anyone think of functions that take an x and y vectors and return a single value?
 
Nathan G

Nathan G

New Member
#219
#219
I'm new to R, but I'm learning fast... With \Huge{ thanks! } to everyone adding to this thread.. Just finished going through all the code.. Simply amazing stuff. I couldn't get everything to work: The unwrap() function was especially frustrating. I tried for a couple hours to no avail; I did get wrap() to work fairly quickly with some substitutions to make it functional on my mac. I realize now the functions I was writing were very raw. But here they are:
1) a function that renames the column names to latex math format for my lab reports - yes I'm an undergrad
2) a search function that returns the first occurrences of unique values in a data.frame column

Code: 
    #################################################
    # 1)
    #	puts $dollar signs in front and behind all column names col_{sub} -> $col_{sub}$		
    #
    ###################################################
  
    amscols <- function(x){ colnames(x) <- paste( "$" , colnames(x) , "$" , sep = "" ) x }

    #################################################
    # 2)
    # Returns a data.frame of the first occurances of all unique values of the "search" column
    #
    ###############################################

    getfirsts <- function(data, searchcol){
    # Receives a data.frame and a "search" column
    # Returns a data.frame of the first occurances of all unique values of the "search" column
	
	  rows <- as.data.frame(match(unique(data[[searchcol]]), data[[searchcol]]))	
	  firsts = data[rows[[1]],]
	
	  return(firsts)
    }
 
You must log in or register to reply here.