# Share your functions & code

#### Lazar

##### Phineas Packard
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

##### ggplot2orBust
Nicely done Dason and nice post Lazar. Brian Diggs is definitely an R guru.

#### trinker

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

a) become a little dorkier

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

#### trinker

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

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

##### New Member
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

##### New Member
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)

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

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

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

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

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

##### ggplot2orBust
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?

#### Dason

No I think the way you're doing it is fine. In 99% of the cases you'll correctly identify the name.

#### trinker

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

##### ggplot2orBust
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?

#### Lazar

##### Phineas Packard
Code:
> euc.dist <- function(x,y) sqrt(sum((x - y) ^ 2))
> v.outer(mtcars, euc.dist)

#### Nathan G

##### New Member
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)
}