merge from git

git-svn-id: https://hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/flowStats@85007 bc3139a8-67e5-0310-9ffc-ced21a209358

DESCRIPTION

@@ -0,0 +1,34 @@
+Package: flowStats
+Type: Package
+Title: Statistical methods for the analysis of flow cytometry data
+Version: 3.21.2
+Author: Florian Hahne, Nishant Gopalakrishnan, Alireza Hadj Khodabakhshi,
+        Chao-Jen Wong, Kyongryun Lee
+Maintainer: Greg Finak <[email protected]> and Mike Jiang <[email protected]>
+Description: Methods and functionality to analyse flow data that is beyond the
+             basic infrastructure provided by the flowCore package.
+Depends: R (>= 2.10), flowCore (>= 1.10.0), fda (>= 2.2.6), mvoutlier, cluster, flowWorkspace (>= 3.7.29)
+Suggests: flowViz, xtable
+Imports: BiocGenerics, MASS, flowViz, flowCore, fda (>= 2.2.6), Biobase, methods, grDevices,
+	 graphics, stats, utils, KernSmooth, lattice,compositions
+Enhances: RBGL,ncdfFlow,graph
+License: Artistic-2.0
+biocViews: FlowCytometry, CellBasedAssays, Bioinformatics
+Lazyload: yes
+Collate: autoGate.R
+	 density1d.R
+	 quadrantGate.R
+	 getPeakRegions.R
+	 singletGate.R
+	 curvPeaks.R
+   gaussNorm.R
+	 landmarkMatrix.R
+	 landmarkMatrixWithoutFilterResult.R 
+	 normalize-methods.R
+	 peakSeparator.R
+	 warpSet.R
+	 pbin.R
+	 gpaSet.R
+	 iProcrustes.R
+	 idFeatures.R
+

NAMESPACE

@@ -0,0 +1,94 @@
+#Generated by codetoolsBioC version 0.0.16
+#Timestamp: Thu Feb 23 13:56:56 2012
+
+#Imports: Biobase, BiocGenerics, KernSmooth, MASS, compositions, fda,
+#         flowCore, flowViz, flowWorkspace, grDevices, graphics,
+#         lattice, methods, mvoutlier, stats, utils
+
+importClassesFrom(flowCore, flowFrame, parameterFilter, parameters)
+
+importClassesFrom(methods, character, list, numeric)
+
+importMethodsFrom(Biobase, channel)
+
+importMethodsFrom(BiocGenerics, cbind, colnames, lapply, mapply, order,
+                  paste, pmax, pmin, rbind, rownames, sapply, setdiff,
+                  table, unique)
+
+importMethodsFrom(flowCore, "%in%", "%subset%", Subset, assign,
+                  "colnames<-", description, "description<-", exprs,
+                  "exprs<-", filter, filterDetails, fsApply, head,
+                  "identifier<-", keyword, ncol, nrow, pData,
+                  "pData<-", parameters, "parameters<-", phenoData,
+                  "phenoData<-", print, sampleNames, sort, split,
+                  summary, tail,colnames,normalize)
+
+importMethodsFrom(flowViz, densityplot, glpolygon, xyplot)
+
+importMethodsFrom(flowWorkspace, getData)
+
+importFrom(Biobase, listLen)
+
+importFrom(KernSmooth, bkde2D)
+
+importFrom(MASS, huber, hubers, rlm)
+
+importFrom(compositions, dist)
+
+importFrom(fda, Data2fd, create.bspline.basis, eval.fd, fdPar,
+           landmarkreg)
+
+importFrom(flowCore, boundaryFilter, char2ExpressionFilter,
+           curv1Filter, curv2Filter, filterList, flowFrame,
+           norm2Filter, quadGate, rectangleGate, sampleFilter)
+
+importFrom(grDevices, chull, col2rgb, contourLines, dev.cur, dev.off,
+           png, rainbow, rgb, x11)
+
+importFrom(graphics, abline, legend, lines, par, plot, points, polygon,
+           rect, text)
+
+importFrom(lattice, make.groups, panel.abline, panel.number,
+           panel.points, panel.polygon, panel.segments,
+           panel.stripplot, panel.text, stripplot, trellis.focus,
+           trellis.par.get, trellis.unfocus, which.packet)
+
+importFrom(methods,  as, is, new, selectMethod)
+
+importFrom(mvoutlier, pcout)
+
+importFrom(stats, anova, approxfun, as.formula, as.hclust, chisq.test,
+           density, dnorm, fitted, formula, kmeans, mad, median,
+           na.omit, optimize, qnorm, quantile, resid, sd, var)
+
+importFrom(utils, capture.output)
+
+export("lymphGate",
+       "lymphFilter",
+       "oneDGate",
+       "quadrantGate",
+       "rangeGate",
+       "rangeFilter",
+       "warpSet",
+#       "warpSetGS",
+#	"warpSetNCDF",
+#	"warpSetNCDFLowMem",
+	"proBin",
+       "binByRef",
+       "gaussNorm",
+       "plotBins",
+       "calcPearsonChi",
+       "calcPBChiSquare",
+       "gpaSet",
+       "iProcrustes",
+       "normQA",
+       "singletGate"
+       )
+
+exportClasses("lymphFilter","rangeFilter")
+
+exportMethods("normalize")
+
+
+exportMethods("%in%")
+

NEWS

@@ -0,0 +1,17 @@
+**************************************************
+*              1.7 SERIES PATCHED NEWS           *
+**************************************************
+
+NEW UTILITIES
+
+o Added an argument 'plot' to lymphGate() to produce plots of results.
+
+o Added an argument 'bwFac' to warpSet() to allow finer control to the
+  smoothing of the density kernal estimation (in curv1Filter). This bandwidth
+  factor would affect the number of landmarks. 
+
+o Added two arguments 'refLine1' and refLine2' to quandrantGate() allowing
+  algorithm to ignore minor, yet significant, sub-populations below 'refLine1'
+  and 'refLine' when calculating the separator between positive and negative.
+
+

R/autoGate.R

@@ -0,0 +1,153 @@
+## 2D gating with norm2Filter. One first selects a rectangle area in the
+## two-dimensional space as a rough preselection and applies the norm2Filter
+## only to this subset in a second step. This function is now considered
+## internal, use lymphGate instead.
+autoGate <- function(x, ..., scale = 2.5)
+{
+    ## some type-checking first
+    flowCore:::checkClass(x, "flowSet")
+    flowCore:::checkClass(scale, "numeric", 1)
+    stains <- names(list(...))
+    if(length(stains) != 2)
+        stop("Only know how to deal with 2 dimensions.", call.=FALSE)
+    ## construct initial rectangle gate and subset
+    rectgate2 <- rectangleGate(...)
+    tmp2 <- Subset(x, filter(x, rectgate2))
+    ## compute norm2Filter for the rest
+    bcn2g <- do.call(norm2Filter,
+                     list(stains[1], stains[2], scale = scale))
+    bcn2f <- filter(tmp2, bcn2g)
+    ans <- Subset(tmp2, bcn2f)
+    list(x = ans, n2gate = bcn2g, n2gateResults = bcn2f)
+}
+
+
+## A more versatile API for autoGate. 'preselection' can be one in
+##   NULL:               basically a regular norm2Filter operation without any
+##                       preselection
+##   a character scalar: The name of one of the channels in x used for the
+##                       preselection. Only positive cells in this channel
+##                       will be considered to construct the rectangle gate.
+##   a list: The same as for autoGate, numerics defining the initial rectangular
+##                       selection
+lymphGate <- function(x, channels, preselection=NULL, scale=2.5,
+                      bwFac=1.3, filterId="defaultLymphGate",
+                      evaluate=TRUE, plot=FALSE, ...)
+{
+    ## some type-checking first
+    flowCore:::checkClass(channels, "character", 2)
+    flowCore:::checkClass(x, c("flowSet", "flowFrame"))
+    flowCore:::checkClass(scale, "numeric", 1)
+    flowCore:::checkClass(bwFac, "numeric", 1)
+    flowCore:::checkClass(filterId, "character", 1)
+    flowCore:::checkClass(evaluate, "logical", 1)
+    bcn2g <- do.call(norm2Filter, list(channels, scale=scale,
+                                       filterId=filterId))
+    if(!is.null(preselection)){
+        if(is.character(preselection)){
+            ## preselect by a single stain
+            flowCore:::checkClass(preselection, "character", 1)
+            if(!preselection %in% colnames(x))
+                stop(sprintf("'%s' is not a valid flow parameter in this flowSet.",
+                            preselection), call.=FALSE)
+            ## collapse to a single flowFrame and find most likely positive peak
+            ## (essentially the one with the highest mean) after removing margin
+            ## events.
+            xc <- as(x, "flowFrame")
+            xc <- Subset(xc, boundaryFilter(preselection))
+            xcf <- filter(xc, curv1Filter(preselection, bwFac=1.3))
+            xcS <- split(xc, xcf)
+            xcS <- xcS[sapply(xcS, nrow)>nrow(xc)/500]
+            xcMax <- Subset(tail(xcS, n=1)[[1]], boundaryFilter(channels))
+            ## estimate location and variance of this subset in the two other
+            ## channels and construct a rectangular preselection from that
+            m <- apply(exprs(xcMax[,channels]), 2, median)
+            s <- scale*apply(exprs(xcMax[,channels]), 2, mad)
+            rg <- list(c(m[1]-s[1], m[1]+s[1]), c(m[2]-s[2], m[2]+s[2]))
+            names(rg) <- channels
+            bcrg <- rectangleGate(.gate=rg, filterId="Preselection")
+        }else if(is.list(preselection)){
+            ## give the preselection as an explicit rectangle
+            sapply(preselection, flowCore:::checkClass, "numeric", 2)
+            if(is.null(names(preselection)))
+                names(preselection) <- channels
+            bcrg <- rectangleGate(preselection, filterId="Preselection")
+        }else stop("Invalid argument 'preselection'.", call.=FALSE)
+        bcn2g <- bcn2g %subset% bcrg
+        identifier(bcn2g) <- filterId
+    }
+    ## compute the filterResult and subset only if evaluate=TRUE
+    xr <- fr <- NULL
+    if(evaluate){
+        fr <- filter(x, bcn2g)
+        xr <- Subset(x, fr)
+    }
+
+    if (evaluate & plot) {
+        fm <- formula(paste(sapply(channels, function(ch) paste("`", ch, "`", sep="")),
+                            collapse="~"))
+        print(xyplot(fm, x, filter=bcn2g))
+
+    }
+
+    return(list(x=xr, n2gate=bcn2g, n2gateResults=fr))
+}
+
+
+
+
+
+## ===========================================================================
+## lymphFilter
+## ---------------------------------------------------------------------------
+## This is basically an abstraction of the lymphGate function. It allows us
+## to use it as a regular gate object.
+## ---------------------------------------------------------------------------
+setClass("lymphFilter",
+         representation=representation(preselection="character",
+                                       rectDef="list", 
+                                       scale="numeric",
+                                       bwFac="numeric"),
+         contains="parameterFilter",
+         prototype=list(filterId="defaultLymphFilter"))
+
+## Constructor. We allow for the following inputs:
+##  scale and bwFac are always numerics of length 1
+##  channels is a characters of length 2
+##  preselection is either a character scalar or a named list
+##  of numerics
+lymphFilter <- function(channels, preselection=as.character(NULL),
+                        scale=2.5, bwFac=1.3, filterId="defaultLymphFilter")
+{
+    flowCore:::checkClass(scale, "numeric", 1)
+    flowCore:::checkClass(bwFac, "numeric", 1)
+    flowCore:::checkClass(filterId, "character", 1)
+    flowCore:::checkClass(channels, "character", 2)
+    rdef <- if(is.list(preselection)){
+        tmp <- preselection
+        preselection <- as.character(NULL)
+        tmp} else list()
+    new("lymphFilter", parameters=channels, preselection=preselection,
+        scale=scale, bwFac=bwFac, filterId=filterId, rectDef=rdef)
+}
+
+
+setMethod("%in%",
+          signature=signature("flowFrame",
+                              table="lymphFilter"),
+          definition=function(x, table)
+      {
+          pre <- if(is.null(table@preselection)) table@rectDef else table@preselection
+          if(length(parameters(table)) != 2)
+              stop("lymph filters require exactly two parameters.")
+          tmp <- lymphGate(x, channels=parameters(table),
+                           preselection=pre,
+                           scale=table@scale,
+                           bwFac=table@bwFac,
+                           filterId=table@filterId,
+                           eval=TRUE,
+                           plot=FALSE)
+          tmp$n2gateResults@subSet
+      })
+
+

R/curvPeaks.R

@@ -0,0 +1,53 @@
+## parse output of curv1Filter and find modes and midpoints of the density
+## regions
+curvPeaks <- function(x, dat, borderQuant=0.01, n=201, from, to, densities=NULL)
+{
+    ## Some type-checking first
+    flowCore:::checkClass(x, "multipleFilterResult")
+    flowCore:::checkClass(dat, c("numeric","NULL"))
+    flowCore:::checkClass(borderQuant, "numeric", 1)
+    flowCore:::checkClass(n, "numeric", 1)
+    if(missing(from))
+        from <- min(dat)
+    flowCore:::checkClass(from, "numeric", 1)
+    if(missing(to))
+        to <- max(dat)
+    flowCore:::checkClass(to, "numeric", 1)
+    ## extract boundaries
+    bound <- attr(x@subSet, "boundaries")
+
+    dens <- if(!is.null(densities)) densities else
+    density(dat, n=n, from=from, to=to, na.rm=TRUE)$y
+    ## iterate over regions
+    regPoints <- list()
+    peaks <- midpoints <- regions <- densFuns <- NULL
+    i <- 1
+    if(!all(is.na(bound[[1]]))){
+        #oo <- options(warn=-1)
+        #on.exit(options(oo))
+        for(b in bound){
+            ## discard regions on the margins
+            if(b[2] > quantile(c(from,to), borderQuant) &&
+               b[1] < quantile(c(from,to), 1-borderQuant)){
+                ## approximate density by function
+                afun <- approxfun(seq(from, to, len=n), dens)
+                sel <- seq(b[1], b[2], len=50)
+                regPoints[[i]] <- cbind(x=sel, y=afun(sel))
+                ## compute maximum of function
+                m <- optimize(afun, b, maximum=TRUE)
+                peaks <- rbind(peaks, cbind(x=m$maximum, y= m$objective))
+                regions <- rbind(regions, cbind(left=b[1], right=b[2]))
+                midpoints <- c(midpoints, mean(b))
+                densFuns <- c(densFuns, afun)
+                i <- i+1
+            }
+        }
+    }
+    if(i==1)
+        return(list(peaks=cbind(x=NA, y=NA), regions=cbind(left=NA, right=NA),
+                    midpoints=NA, regPoints=list(cbind(x=NA, y=NA)),
+                    densFuns=NA))
+    return(list(peaks=peaks, regions=regions, midpoints=midpoints,
+                regPoints=regPoints, densFuns=densFuns))
+}
+