Add files via upload

Added a few R functions

Author: flowscience

cor.prob.R

@@ -0,0 +1,10 @@
+## Correlation matrix with p-values. See http://goo.gl/nahmV for documentation of this function
+cor.prob <- function (X, dfr = nrow(X) - 2) {
+  R <- cor(X, use="pairwise.complete.obs")
+  above <- row(R) < col(R)
+  r2 <- R[above]^2
+  Fstat <- r2 * dfr/(1 - r2)
+  R[above] <- 1 - pf(Fstat, 1, dfr)
+  R[row(R) == col(R)] <- NA
+  R
+}

exploratory_analysis.R

@@ -0,0 +1,51 @@
+#Produce a histogram for each variable in a dataset.
+all.hist <- function(x){
+  sapply(colnames(x), function(i)hist(x[,i], main = i,
+      xlab="Value", col="lightblue")) 
+}
+
+#Produce a kernel density plot w/normal curve for each
+#variable in a dataset.
+all.density.plot <- function(x){
+  sapply(colnames(x), function(i)plot(density(x[,i]),
+        main = i, xlab="Value", col="red", lwd=2))  
+}
+
+#Produce a scatterplot matrix with histograms
+#on the diagonal and correlation statistics in the 
+#upper panel using the base function pairs() 
+#http://handlesman.blogspot.com/2011/03/matrix-plot-with-confidence-intervals.html
+
+## put histograms on the diagonal
+panel.hist <- function(x, ...)
+{
+    usr <- par("usr"); on.exit(par(usr))
+    par(usr = c(usr[1:2], 0, 1.5) )
+    h <- hist(x, plot = FALSE)
+    breaks <- h$breaks; nB <- length(breaks)
+    y <- h$counts; y <- y/max(y)
+rect(breaks[-nB], 0, breaks[-1], y, col="lavender", ...)
+}
+
+## put correlations & 95% CIs on the upper panels,
+panel.cor <- function(x, y, digits=2, prefix="", cex.cor, ...)
+{
+    usr <- par("usr"); on.exit(par(usr))
+    par(usr = c(0, 1, 0, 1))
+    r <- cor(x, y,use="complete.obs")
+    txt <- format(c(r, 0.123456789), digits=digits)[1]
+    prefix <- "r = "
+    rc <- cor.test(x,y)
+    rci <- rc$conf.int
+    txt2 <- format(c(rci, 0.123456789), digits=digits)[1]
+    txt3 <- format(c(rci, 0.123456789), digits=digits)[2]
+    prefix2 <- "\nCI = "
+    txt <- paste(prefix, txt, prefix2, txt2, ", ", txt3, sep="")
+    if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
+    text(0.5, 0.5, txt, cex = 1)
+}
+
+#Combine helper functions
+pairs(iris[1:4], lower.panel=panel.smooth, cex = .8, pch = 21, bg="steelblue",
+       diag.panel=panel.hist, cex.labels = 1.2, font.labels=2, upper.panel=panel.cor) 
+

hyperG_nestedLists.r

@@ -0,0 +1,28 @@
+hyperG <- function(list1, list2){
+		library(reshape2)
+		uni1 <- sum(sapply(list1, length))
+		uni2 <- sum(sapply(list1, length))
+		universe <- max(c(uni1,uni2))
+		universe=1904
+		intersects <- sapply(list1, function(x) sapply(list2, function(y) length(intersect(x,y))))
+		len1 <- t(as.data.frame(lapply(list1, length)))
+		len2 <- t(as.data.frame(lapply(list2, length)))
+		out <- cbind(melt(intersects), len_Var1=rep(len1, each=length(len2)), len_Var2=rep(len2, times=length(len1)))
+		out <- subset(out, len_Var1 >= 5 & len_Var2 >=5)
+		pvalue <- apply(out[,3:5], 1, function(x) 1-phyper(x[1],x[2],universe-x[2],x[3]))
+		FDR <- p.adjust(pvalue, method='fdr')
+		out <- cbind(out, pvalue, FDR)
+		colnames(out) <- c('Var1', 'Var2', 'Overlap', 'len_Var1', 'len_Var2', 'pvalue', 'FDR')
+		out
+}
+
+#Probability of getting 100 or more white balls in a sample of size 400 from an urn 
+#with 3000 white balls and 12000 black balls
+# white balls retrieved = overlap-1 (e.g. 100 or more)
+# total white balls = cluster size
+# total black balls = universe - cluster size
+# total draws = category size
+#cluster/category size are interchangable, but universe must always substact the former
+#1-phyper(white balls, total white balls, black balls, size)
+#1-phyper(99, 3000, 12000, 400)
+#1-phyper(overlap-1, cluster size, universe-cluster size, category size)