R/gateplotting_utils.R

Defines functions multFiltPoints addLpoints ell2Polygon norm2Ell norm2Polygon fixBound_addName fixInf nnWarn checkFres evalError dropWarn checkIdMatch checkParameterMatch fmatchWarn plotType state .flowViz.par.init

## Helper functions that will be needed for all of the gate plotting functions
## These are mostly functions that do some sanity checking.
#require(grDevices)  # RColorBrewer assumes 'rgb' on the search path

## Store state info in this internal environment
flowViz.state <- new.env(hash = FALSE)


# based on colorRampPalette
# add the optional alpha control
#' @param alpha \code{numeric} range from 0 to 1
#' @importFrom grDevices rgb colorRamp colorRampPalette col2rgb
#' @importFrom RColorBrewer brewer.pal
.colRmpPlt <- function (alpha = 1, ...) 
{
  
  colors <- rev(brewer.pal(11, "Spectral"))
  ramp <- colorRamp(colors, ...)
  function(n) {
    x <- ramp(seq.int(0, 1, length.out = n))
    rgb(x[, 1L], x[, 2L], x[, 3L], maxColorValue = 255, alpha = alpha * 255)
  }
}

## FIXME: We hardcode a lattice theme for the X11xcairo device for now which will be
## used for all other devices as well. Later this should follow the example from the
## lattice package, i.e., real device-specific themes that are set up once the device
## is first called.
.flowViz.par.init <- function(lattice.par){
  gate.par <- list(gate=list(alpha=1,
                              cex=NULL,
                              pch=NULL,
                              col="#9E0142"#"red",
                              ,fill="transparent",
                              lwd=1,
                              lty="solid"),
                        gate.text=list(font=1,
                                        col="#000000",
                                        alpha=1,#0.4,
                                        cex=0.8,#1.2,
                                        lineheight=0.8#1.2
                                        ,background=list(fill="white"
                                                        ,col="transparent"
                                                        ,alpha=1
                                                    )
                                    ),
                        overlay.symbol = list(alpha = 0.5
                                              ,bg.alpha = 0.3
                                              ,col = "transparent"
                                              ,fill = "red"
                                              ,cex = 0.5
                                              , pch = 19
                                          ),                 
                        flow.symbol=list(alpha=1,
                                            cex = 0.1,
                                            pch = 19,
                                            col="black",
                                            fill="transparent"),
                        gate.density=list(alpha=1,
                                          fill="#FFFFFFB3",
                                          col="black",
                                          lwd=1,
                                          lty="dotted")
                                      
                        ,argcolramp = .colRmpPlt()
                    )
  flowViz.state[["lattice.theme"]] <- list(X11cairo= c(gate.par, lattice.par))
}
# can't do it within Namespace events hooks (e.g. .onLoad) 
# since it needs to load namespace (e.g. 'rgb' through 'brewer.pal' call
# other than base namespace
#' @importFrom latticeExtra ecdfplot ggplot2like axis.grid
.flowViz.par.init(lattice.par = ggplot2like())

## Get and set graphical defaults for plots in flowViz. To a great extend, this uses
## the trellis.par.get and trellis.par.set infrastructure defined in the lattice package.
## Currently it is not possible to directly register additional setting there, instead
## we provide our own wrappers which look for available defaults in lattice first and
## fetch or set additional defaults within the internal flowViz environment if they can't
## be found in the lattice defaults.


#' Query and set session-wide graphical parameter defaults.
#' 
#' 
#' \code{flowViz.par.get} is the equivalent to
#' \code{\link[lattice]{trellis.par.get}}. It queries the session wide defaults
#' for all \code{lattice} and \code{flowViz} graphical parameters.
#' 
#' \code{flowViz.par.set} is the equivalent to
#' \code{\link[lattice:trellis.par.get]{trellis.par.set}}. It sets the same set
#' of graphical parameters, either in the \code{flowViz} package or directly in
#' \code{lattice}.
#' 
#' 
#' Getting and setting graphical parameters in \code{flowViz} follows exactly
#' the mechanism of the \code{lattice} package. For all purpose and intentions,
#' \code{flowViz.par.get} and \code{flowViz.par.get} can be viewed as wrappers
#' around their \code{lattice} counterparts
#' \code{\link[lattice]{trellis.par.get}} and
#' \code{\link[lattice:trellis.par.get]{trellis.par.set}} and you should
#' consult their documentation for further details.
#' 
#' We introduce four new categories of graphical parameters that are relevant
#' for \code{flowViz} plots:
#' 
#' \describe{ \item{gate}{Controls the appearance of gate boundaries in
#' \code{xyplots} (if \code{smooth=TRUE}) or of the points within a gate region
#' (\code{smooth=FALSE}).  Available parameters are \code{col},
#' \code{cex},\code{pch},\code{alpha},\code{lwd},\code{lty} and \code{fill}. }
#' 
#' \item{gate.density}{Controls the appearance of gate boundaries in
#' \code{densityplots}.  Available parameters are \code{col},
#' \code{alpha},\code{lwd},\code{lty} and \code{fill}. }
#' 
#' \item{flow.symbol}{Controls the appearance of 'regular' points in a
#' \code{flowViz} plot.  Available parameters are \code{col},
#' \code{cex},\code{pch},\code{alpha} and \code{fill}. }
#' 
#' \item{gate.text}{Controls the appearance of the text used for gate names.
#' Available parameters are \code{col}, \code{cex},\code{font},\code{alpha} and
#' \code{lineheight}. } }
#' 
#' @aliases flowViz.par.get flowViz.par.set
#' @param name The name of a parameter category to set.
#' @param value A named list of values to set for category \code{name} or a
#' list of such lists if \code{name} is missing.
#' @param \dots Further arguments that get passed on.
#' @param theme The theme to set. See
#' \code{\link[lattice:trellis.par.get]{trellis.par.set}} for details.
#' @param warn This gets passed on directly to \code{trellis.par.set}.
#' @param strict This gets passed on directly to \code{trellis.par.set}.
#' @param reset \code{logical} scalar. When TRUE, drop the entire list of old
#' graphical parameters and reset it with the supplied one. Default is FALSE,
#' which updates the existing parameters.
#' @return
#' 
#' \code{flowViz.par.get} returns a list of graphical parameter defaults, if
#' \code{name} is not empty, only for this particular category. For an empty
#' \code{name} argument, the function returns all parameter defaults, including
#' the ones specified in the lattice package.
#' 
#' \code{flowViz.par.set} is called for its side-effects of setting default
#' parameters.
#' @note
#' 
#' Because parameter settings in \code{lattice} are device-dependent,
#' \code{flowViz.par.get} will open a (default) device none is open at the time
#' of the query.
#' @author F. Hahne
#' @seealso
#' 
#' \code{\link[lattice]{trellis.par.get}} and
#' \code{\link[lattice:trellis.par.get]{trellis.par.set}}
#' @references Deepayan Sarker, \emph{Lattice, Multivariate Data Visualization
#' with R}, Springer, New York, 2008
#' @examples
#' 
#' 
#' ## Return all available parameters, including lattice ones
#' flowViz.par.get()
#' 
#' ## Set the font for gate names 
#' flowViz.par.set("gate.text", list(font=2))
#' 
#' ## Query only the gate.text category
#' flowViz.par.get("gate.text")
#' 
#' ## Set a lattice parameter
#' plot.symbol <- trellis.par.get("plot.symbol")
#' flowViz.par.set("plot.symbol", list(col="red"))
#' trellis.par.get("plot.symbol")
#' 
#' ## undo all settings
#' flowViz.par.set(list(plot.symbol=plot.symbol, gate.text=list(font=1)))
#' library(flowCore)
#' data(GvHD)
#' fs <- GvHD[1:2]
#' 
#' # using default ggplot2like theme
#' densityplot(~`FSC-H`, fs)
#' xyplot(`SSC-H`~`FSC-H`, fs, smooth = FALSE)
#'             
#' # reset it with default lattice theme            
#' flowViz.par.set(theme =  trellis.par.get(), reset = TRUE)
#' densityplot(~`FSC-H`, fs)
#' xyplot(`SSC-H`~`FSC-H`, fs, smooth = FALSE)
#' 
#' 
#' @export 
#' @importFrom utils modifyList
flowViz.par.get <- function (name = NULL) 
{
  ## FIXME: We want this to be device-specific, needs to be set up in the same
  ## way as it is done in lattice.
  lPars <- flowViz.state[["lattice.theme"]]$X11cairo
  if (is.null(name)) 
    lPars
  else if (name %in% names(lPars)) 
    lPars[[name]]
  else NULL
}

#' @export
#' @rdname flowViz.par.get
flowViz.par.set <- function (name, value, ..., theme, warn = TRUE, strict = FALSE, reset = FALSE) 
{
  if (missing(theme)) {
    if (!missing(value)) {
      theme <- list(value)
      names(theme) <- name
    }
    else if (!missing(name) && is.list(name)) {
      theme <- name
    }
    else theme <- list(...)
  }
  else {
    if (is.character(theme)) 
      theme <- get(theme)
    if (is.function(theme)) 
      theme <- theme()
    if (!is.list(theme)) {
      warning("Invalid 'theme' specified")
      theme <- NULL
    }
  }
  
  #reset by dropping all the existing lattic par
  if(reset){
    .flowViz.par.init(lattice.par = theme)  
  }else{
    fvPars <- names(theme) %in% names(flowViz.state[["lattice.theme"]]$X11cairo)
    
    if (strict)
      flowViz.state[["lattice.theme"]]$X11cairo[names(theme[fvPars])] <- theme[fvPars]  
    else flowViz.state[["lattice.theme"]]$X11cairo <-
          lattice:::updateList(flowViz.state[["lattice.theme"]]$X11cairo, theme[fvPars])
    
  }
  invisible()
}




## return the state information from the internal environment
state <- function(x) flowViz.state[[x]]

plotType <- function(type, parms){
	return (list(plotted= TRUE
				,type=type
				,parameters= parms)
			)
}




## We only know how to add the gate boundaries if the definiton of that gate
## contains exactly two dimensions, and even then we need to guess that
## they match the plotted data, hence we warn
fmatchWarn <- function(parms, verbose=TRUE)
{
    if(verbose)
        warning("The filter is defined for parameters '",
                paste(parms, collapse="' and '"), "'.\nPlease make sure ",
                "that they match the plotting parameters.", call.=FALSE)
}

checkParameterMatch <- function(parms,channels, verbose=TRUE, strict=TRUE,ptList, ...)
{
	parameters<-ptList$parameters
	plotted<-ptList$plotted
    if(missing(channels)){
        if(plotted && length(parameters==2)){
            sparms <- parameters
            err <-   function(strict=TRUE){
                if(strict)
                    stop("The flow parameters used in the last plot don't match ",
                         "the\nparameters provided by the filter or via the ",
                         "'channels' argument.\n   Plotted: ",
                         paste(sparms, collapse=" vs. "), "\n   Provided: ",
                         paste(parms, collapse=", "),
                         "\nPlease check or redraw the plot.", call.=FALSE)
            }
            mt <- sparms %in% parms
            if(length(parms)<2){
                if(!parms %in% sparms){
                    err(strict)
                    return(NA)
                }
            }else if(!all(mt)){
                err(strict)
                return(NA)
            }
            return(sparms)
        }else{
            fmatchWarn(parms, verbose=verbose)
            return(parms)
        }
    }else{
        parms <- channels
        if(length(parms)!=2 && strict)
            stop("The filter definition contains the following parameters:\n",
                 paste(parms, collapse=", "), "\nDon't know how to match to",
                 " the plotted data.\nPlease specify plotting parameters as ",
                 "an additional argument.", call.=FALSE)
        return(parms)
    }
}


## We check that the IDs of a flowFrame and a filter are matching
checkIdMatch <- function(x, f)
{
    if(!identifier(f) %in% x@frameId)
        stop("The filter was evaluated on flowFrame(s)\n'",
             paste(x@frameId, collapse="', '", sep=),
             "'\n  but the frame provided is '",
             identifier(f), "'.", call.=FALSE)
}


## Warning when we ignore an argument that is not needed
dropWarn <- function(type, gate, verbose=FALSE)
{
    if(verbose)
        warning("No '", type, "' needed to plot '", gate,
                "'.\nArgument is ignored.", call.=FALSE)
}


## Cast error that we need the data to evaluate the filter
evalError <- function(type)
{
    stop("'", type, "' need to be evaluated for plotting.\n",
         "Either provide a 'flowFrame' or an appropriate ",
         "'filterResult' \nas second argument.", call.=FALSE)
}

## check that a filterResult and a filter actually match
checkFres <- function(filter, fres, verbose=TRUE)
{
    fd <- filterDetails(fres, identifier(filter))
    if(!identical(identifier(filter), identifier(fres)))
        stop("The 'filterResult' and the '", class(filter),
             "' don't match.", call.=FALSE)
}

## We don't know how to draw 'type' filters, hence we warn
nnWarn <- function(type, verbose=TRUE)
{
    if(verbose)
        warning("Don't know how to plot outline for a '", type,
                "'.", call.=FALSE)
    return(invisible(NULL))
}

## replace infinite values by something useful
fixInf <- function(x, replacement)
{
#	browser()
    for(i in seq_along(x)){
        y <- x[i]
        if(is.infinite(y) && y<0)
            x[i] <- replacement[1]-diff(replacement)*10
        else if(is.infinite(y) && y>0)
            x[i] <- replacement[2]+diff(replacement)*10
    }
    return(x)
}
##fixInf returned the exagerated bounaries which does not give good esitmation of label position for gates
##so we add another version here specifically for addName methods
fixBound_addName <- function(x, range)
{
#	browser()
	for(i in seq_along(x)){
		y <- x[i]
		if(y<range[1])
			x[i] <- range[1]
		else if(y>range[2])
			x[i] <- range[2]
	}
	return(x)
}

## convert a norm2Filter into a polygonGate
norm2Polygon <- function(fd, parms=fd$parameters)
{
    ## get the ellipse lines
    norm.center <- fd$center[parms]
    norm.cov <- fd$cov[parms, parms]
    norm.radius <- fd$radius
    chol.cov <- t(chol(norm.cov))
    t <- seq(0, 2 * base::pi, length = 50)
    ans <- norm.center +
        (chol.cov %*% rbind(x = norm.radius * cos(t),
                            y = norm.radius * sin(t)))
    ans <- as.data.frame(t(ans))
    names(ans) <- parms
    ## create a polygonGate
    polygonGate(.gate=ans)
}

## convert a norm2Gate into an ellipsoidGate
norm2Ell <- function(fd, parms=fd$parameters)
{
    ellipsoidGate(mean=fd$center[parms],
                  cov=fd$cov[parms, parms],
                  distance=fd$radius)
}

## convert an ellipseoidalFilter into a polygonGate
ell2Polygon <- function(fd, parms=parameters(fd))
{
  .Deprecated("as")
    ## get the ellipse lines
    center <- fd@mean[parms]
    if(is.null(rownames(fd@cov)))
      rownames(fd@cov) <- colnames(fd@cov)
    cov <- fd@cov[parms, parms]
    radius <- fd@distance
    chol.cov <- t(chol(cov))
    t <- seq(0, 2 * base::pi, length = 50)
    ans <- center +
        (chol.cov %*% rbind(x = radius * cos(t),
                            y = radius * sin(t)))
    ans <- as.data.frame(t(ans))
    names(ans) <- parms
    ## create a polygonGate
    polygonGate(.gate=ans)
}


## Helper function that calls panel.x in a more user-fiendly way
glrect <- function (xleft, ybottom, xright, ytop, ..., gp) 
{
    panel.rect(xleft, ybottom,  xright, ytop, col=gp$fill,
               border=gp$col, lty=gp$lty, lwd=gp$lwd,
               alpha=gp$alpha, ...)
}

gltext <- function (x, y, labels, ..., gp) 
{   
#    browser()
#    gp_txt <- gp
#    gp_txt$background <- NULL
#    txtObj <- textGrob(label = labels, gp = gpar(gp_txt), default.units = "native")
    cex <- gp$cex    
	#add rectange as white background for the better visual effect when label is plotted against color 
	grid.rect(x=unit(x,"native")
			,y=unit(y,"native")
#			,width= unit(cex, "grobwidth", data = txtObj)#unit(1,'strwidth',labels)
#			,height=unit(cex, "grobheight", data = txtObj) #unit(1,'strheight',labels)
            ,width= unit(cex,'strwidth',labels)
            ,height=unit(cex,'strheight',labels)
			, gp=gpar(fill=gp$background$fill
					,col=gp$background$col
					,alpha=gp$background$alpha
					)
	)
#	browser()
		
    panel.text(x, y, labels=labels, col=gp$col, cex=gp$cex,
               linheight=gp$lineheigt, alpha=gp$alpha, font=gp$font)
}

glpoly <- function (x, y, ..., gp) 
{
    panel.polygon(x, y, labels=labels, border=gp$col, col=gp$fill,
                  lty=gp$lty, lwd=gp$lwd, alpha=gp$alpha, ...)
}





## Default function to plot points for a single gate region. This uses the
## existing Subset architecture, hence it only works for filters that
## produce logicalFilterResults so far
addLpoints <- function(x, data, channels, verbose=TRUE,
                       filterResult=NULL, gpar, ...)
{
    ## We check if the filterResult matches the filter and subset with that
    if(!is.null(filterResult)){
        if(!identical(identifier(x), identifier(filterResult)) ||
           class(x) != class(filterDetails(filterResult)[[1]]$filter))
            stop("The 'filterResult' and the filter object ",
                 "don't match.", call.=FALSE)
        x <- filterResult
    }
    exp <- exprs(Subset(data, x))
    
    panel.points(exp[,channels[1]], exp[,channels[2]],
                 pch=gpar$pch, cex=gpar$cex, col=gpar$col,
                 fill=gpar$fill, alpha=gpar$alpha, ...)
    return(invisible(NULL))
}


## Helper function to add points for multipleFilterResults.
## We check that the filterResult matches the filter and split by that
## The first component is everything outside not in the filter and we
## drop that
multFiltPoints <-  function(x, data, channels, verbose=TRUE,
                            filterResult=NULL, gpar, ...)
{
    if(is.null(filterResult))
        filterResult <- filter(data, x)
    checkIdMatch(x=filterResult, f=data)
    x <- filterResult 
    datsplit <- split(data, x)[-1]
    ld <- length(datsplit)
    ## we want to be able to use different colors for each population
    col <- rep(gpar$col, ld)[1:ld]
    for(i in 1:ld){
        gpar$col <- col[i]
        panel.points(exprs(datsplit[[i]])[,channels[1]],
                     exprs(datsplit[[i]])[,channels[2]],
                     pch=gpar$pch, cex=gpar$cex,
                     col=gpar$col, alpha=gpar$alpha,
                     fill=gpar$fill, ...)
    }
    return(invisible(NULL))
}

Try the flowViz package in your browser

Any scripts or data that you put into this service are public.

flowViz documentation built on Nov. 8, 2020, 7:53 p.m.