Added data for the RobinsonDelhomme2014 aspen sexual dimorphism manuscript

src/R/densityPlot.R

+## this function is originally from the lSD package
+## modified to suppress the change of margins
+
+setGeneric(name="densityPlot",
+           def=function(x, y, grid = 100, 
+                        ncol = 30, 
+                        nlevels = 10, ...){
+  standardGeneric("densityPlot")
+})
+
+setMethod(f="densityPlot",
+          signature=c("numeric","numeric"),
+          definition=function(x, y, grid = 100, ncol = 30, 
+                              nlevels = 10, ...){
+            if (!is.vector(x) | !is.vector(y)) 
+              stop("First two argument must be vectors !")
+            if (length(x) != length(y)) 
+              stop("Data vectors must be of the same length !")
+            d = LSD:::kde2d.adj(x, y, n = grid)
+            z <- d$z
+            nrz <- nrow(z)
+            ncz <- ncol(z)
+            couleurs <- tail(topo.colors(trunc(1.4 * ncol)), ncol)
+            image(d, col = couleurs, ...)
+            contour(d, add = TRUE, nlevels = nlevels)
+            box()
+          })
\ No newline at end of file

src/R/plot.multidensity.R

+"plot.multidensity" <- function(x,xlab="x",col=brewer.pal(8,"Dark2"),
+                                legend.x="top",xlim=NULL,ylim=NULL,
+                                lty=1,legend.cex=1,...){
+
+  ## pckg
+  library(RColorBrewer)
+  
+  ## check
+  stopifnot(is.list(x))
+  
+  ## densities
+  dens <- lapply(x,density)
+  if(is.null(xlim)){
+    xlim <- range(sapply(dens,"[[","x"))
+  }
+  if(is.null(ylim)){
+    ylim <- range(sapply(dens,"[[","y"))
+  }
+
+  ## lty
+  if(length(lty)==1){
+    lty <- rep(lty,length(dens))
+  }
+  
+  ## plot
+  plot(0,0,xlim=xlim,ylim=ylim,ylab="density",type="n",xlab=xlab,...)
+  
+  ## lines
+  sapply(1:length(dens),function(i,dens,col,...){lines(dens[[i]],col=col[i],lty=lty[i],...)},dens,col,...)
+  
+  ## legend
+  legend(legend.x,col=col[1:length(x)],bty="n",legend=names(x),lty=lty,cex=legend.cex)
+}
+

src/R/plotDispLSD.R

+require("LSD") 
+
+plotDispLSD <- function(cds, name = NULL, ymin, linecol = "#00000080", xlab = "mean of normalized counts", 
+           ylab = "dispersion", log = "xy", cex = 0.45, ...) 
+ {
+   px = rowMeans(counts(cds, normalized = TRUE))
+   sel = (px > 0)
+   px = px[sel]
+   py = fitInfo(cds, name = name)$perGeneDispEsts[sel]
+   if (missing(ymin)) 
+     ymin = 10^floor(log10(min(py[py > 0], na.rm = TRUE)) - 
+                       0.1)
+   heatscatter(log10(px), log10(pmax(py, ymin)), xlab = xlab, ylab = ylab, 
+               pch = ifelse(py < ymin, 6, 16), cex = cex, 
+               xaxt='n', yaxt='n', ...)
+
+   # Fix logged axes labels
+   atx <- axTicks(1)
+   aty <- axTicks(2)
+   xlabels <- sapply(atx, function (i)
+                as.expression(bquote(10^ .(i)))
+              )
+   ylabels <- sapply(aty, function (i)
+                as.expression(bquote(10^ .(i)))
+              )
+   axis(1, at=atx, labels=xlabels)
+   axis(2, at=aty, labels=ylabels)
+   xg = 10^seq(-0.5, 5, length.out = 100)
+   lines(log10(xg), log10(fitInfo(cds, name = name)$dispFun(xg)), col = linecol, 
+         lwd = 4, lty = 1
+    )
+ }
+
+plotMALSD <- function (x, ylim, sign=0.05, col = 'forestgreen',
+    linecol = "#00000080", xlab = "mean of normalized counts",
+    ylab = expression(log[2] ~ fold ~ change), log = "x", cex = 0.45,
+    ...)
+{
+    if (!(is.data.frame(x) && all(c("baseMean", "log2FoldChange") %in%
+        colnames(x))))
+        stop("'x' must be a data frame with columns named 'baseMean', 'log2FoldChange'.")
+    x = subset(x, baseMean != 0)
+    py = x$log2FoldChange
+    if (missing(ylim))
+        ylim = c(-1, 1) * quantile(abs(py[is.finite(py)]), probs = 0.99) *
+            1.1
+    heatscatter(log10(x$baseMean), pmax(ylim[1], pmin(ylim[2], py)),
+        pch = ifelse(py < ylim[1], 6, ifelse(py > ylim[2], 2, 16)),
+        cex = cex,
+        xlab = xlab,
+        ylab = ylab,
+        xaxt = 'n',
+        ylim = ylim, ...)
+
+    # Fix logged x-axis
+    atx <- axTicks(1)
+    labels <- sapply(atx, function (i)
+                as.expression(bquote(10^ .(i)))
+              )
+    axis(1, at=atx, labels=labels)
+    abline(h = 0, lwd = 4, col = linecol, lty=1)
+
+    # Mark the significant DEGs, quite ugly, right?
+    sign <- subset(x, padj < sign)
+    pointy <- sign$log2FoldChange
+    points(log10(sign$baseMean),
+      pmax(ylim[1], pmin(ylim[2], pointy)),
+      pch = 1,
+      col = col,
+      cex = cex + 0.5)
+}

src/R/plotMA.R

+setMethod(f="plotMA",
+          signature="DataFrame",
+          definition=function(object,alpha=0.001){
+            
+            ## lib
+            require(LSD)
+            
+            ## check
+            if(!existsFunction("densityPlot")){
+              stop("Load the densityPlot function prior to using this function.")
+            }
+            
+            ## selectors
+            sel <- ! is.na(object$padj)
+            sel2 <- object$padj[sel]<=alpha 
+            
+            ## graphic params
+            orig.par <- par(no.readonly=TRUE)
+            par(mfrow=c(2,1))
+            
+            ## plots
+            densityPlot(log10(object$baseMean[sel]),
+                      object$log2FoldChange[sel],
+                      grid=250,ncol=30,nlevels=10,
+                      main="MA density estimation"
+                      )
+            mtext("log10 mean expression",side=2,line=2)
+            mtext("log2 FC",side=1,line=2)
+            
+            heatscatter(log10(object$baseMean[sel]),
+                        object$log2FoldChange[sel],
+                        add.contour=TRUE,main="MA",
+                        xlab="log10 mean expression",
+                        ylab="log2 FC",sub=paste(sum(sel2),
+                                                 "sign. feats. @",
+                                                 alpha,"cutoff"))
+            
+            points(log10(object$baseMean[sel][sel2]),
+                   object$log2FoldChange[sel][sel2],
+                   col="darkred",pch=19,cex=.5)
+            
+            legend("topright",pch=19,col="darkred","sign. feats.")
+            
+            par(orig.par,no.readonly=TRUE)
+            invisible(TRUE)
+          })

src/R/volcanoPlot.R

+setGeneric(name="volcanoPlot",def=function(object,alpha=0.001){
+  standardGeneric("volcanoPlot")
+})
+
+setMethod(f="volcanoPlot",
+          signature="DataFrame",
+          definition=function(object,alpha=0.001){
+
+            ## lib
+            require(LSD)
+            
+            ## selectors
+            sel <- ! is.na(object$padj)
+            sel2 <- object$padj[sel]<=alpha 
+
+            ## plot
+            heatscatter(object$log2FoldChange[sel],
+                        -log10(object$padj[sel]),
+                        main="Volcano",xlab="Log2 Fold Change", 
+                        ylab="- log(10) adj. p-value")
+
+            ## legend
+            legend("topleft",bty="n",paste("cutoff @",alpha),lty=2,col="gray")
+            
+            ## points
+            points(object$log2FoldChange[sel][sel2],-log10(object$padj[sel][sel2]),col="lightblue",pch=19)
+            points(object$log2FoldChange[sel][sel2],-log10(object$padj[sel][sel2]),col="dodgerblue3",pch=19,cex=0.5)
+
+            ## circle the points for the dot plot
+            abline(h=-log10(alpha),lty=2,col="gray")
+            })