R/add_Methods.R

In RGLab/flowWorkspace: Infrastructure for representing and interacting with gated and ungated cytometry data sets.

#' @include filterObject_Methods.R
NULL

#' @templateVar old add
#' @templateVar new gs_pop_add
#' @template template-depr_pkg
NULL

#' @export
add <- function(gs, gate,...)UseMethod("add")

#' @export 
add.default <- function(gs, gate,...)
		{
			.Deprecated("gs_pop_add")
			gs_pop_add(gs, gate, ...)
			
}

#' Create a GatingSet and add/remove the flowCore gate(or population) to/from a GatingHierarchy/GatingSet.
#' 
#' \code{GatingSet} method creates a gatingset from a flowSet with the ungated data as the root node.
#' \code{add} method add the flowCore gate to a GatingHierarchy/GatingSet.
#' \code{gs_pop_set_gate} method update the gate of one population node in GatingHierarchy/GatingSet.
#' \code{Rm} method Remove the population node from a GatingHierarchy/GatingSet. 
#' They are equivalent to the \code{workFlow},\code{add} and \code{Rm} methods in \code{flowCore} package. 
#' \code{recompute} method does the actual gating after the gate is added,i.e. calculating the event indices according to the gate definition.   
#' 
#' @name gs_pop_add
#' @aliases add add,default-method Rm
#' @param gs A \code{GatingSet}
#' @param gate A \code{flowCore::filter} or a list of \code{flowCore::filter}s or \code{logical} vectors to be added to the \code{GatingSet}.
#'             when logical vectors, they represent the indices of events to be included in the populations. It can be global that represents
#'             the index to the original full events or local index that is relative to the parent population cell events. See examples for more
#'             details.
#' @param ... some other arguments to specify how the gates are added to the gating tree.
#' \itemize{
#' 		\item names  a \code{character} vector of length four,which specifies the population names resulted by adding a \code{quadGate}.The order of the names is clock-wise starting from the top left quadrant population.
#' 		\item parent a \code{character} scalar to specify the parent node name where the new gate to be added to, by default it is NULL,which indicates the root node
#' 		\item name a \code{character} scalar to specify the node name of population that is generated by the gate to be added.
#' 		\item recompute a \code{logical} flag
#' 
#'       \item negated: a \code{logical} scalar to specify whether the gate is negated,which means the the population outside of the gate will be kept as the result population.
#'       It is FALSE by default. 
#'  }
#' @param node A \code{character} identifies the population node in a \code{GatingHierrarchy} or \code{GatingSet} to remove
#' @return 
#'   \code{GatingSet} method returns a \code{GatingSet} object with just root node.  
#'   \code{add} method returns a population node ID (or four population node IDs when adding a \code{quadGate}) that uniquely identify the population node within a  \code{GatingHierarchy}.
#' @seealso \code{\link{GatingSet-class}}
#' @examples
#' \dontrun{
#'     library(flowCore)
#'     data(GvHD)
#' #select raw flow data
#'     fs<-GvHD[1:3]
#'     
#' #transform the raw data
#'     tf <- transformList(colnames(fs[[1]])[3:6], asinh, transformationId="asinh")
#'     fs_trans<-transform(fs,tf)
#'     
#' #add transformed data to a gatingset
#'     gs <- GatingSet(fs_trans)
#'     gs
#'     gs_get_pop_paths(gs[[1]]) #only contains root node
#'     
#' #add one gate
#'     rg <- rectangleGate("FSC-H"=c(200,400), "SSC-H"=c(250, 400),
#'         filterId="rectangle")
#'     
#'     nodeID<-gs_pop_add(gs, rg)#it is added to root node by default if parent is not specified
#'     nodeID
#'     gs_get_pop_paths(gs[[1]]) #the second population is named after filterId of the gate 
#'     
#' #add a quadGate
#'     qg <- quadGate("FL1-H"=2, "FL2-H"=4)
#'     nodeIDs<-gs_pop_add(gs,qg,parent="rectangle")
#'     nodeIDs #quadGate produces four population nodes
#'     gs_get_pop_paths(gs[[1]]) #population names are named after dimensions of gate if not specified
#'     
#' #add a boolean Gate
#'     bg<-booleanFilter(`CD15 FITC-CD45 PE+|CD15 FITC+CD45 PE-`)
#'     bg
#'     nodeID2<-gs_pop_add(gs,bg,parent="rectangle")
#'     nodeID2
#'     gs_get_pop_paths(gs[[1]])
#' #do the actual gating
#'     recompute(gs)
#'     
#' #plot one gate for one sample
#'     autoplot(gs[[1]],"rectangle")
#'     autoplot(gs[[1]],nodeIDs) #may be smoothed automatically if there are not enough events after gating
#'     
#' #plot gates across samples 
#'     autoplot(gs,nodeID)
#' #plot all gates for one sample
#'     autoplot(gs[[1]])#boolean gate is skipped by default 
#'     autoplot(gs[[1]],bool=TRUE)
#'     
#' #plot the gating hierarchy
#'     plot(gs[[1]])
#' #remove one node causing the removal of all the descendants 
#'     gs_pop_remove('rectangle', gs = gs)
#'     gs_get_pop_paths(gs[[1]])
#'     
#'     #add logical vectors as gate
#'     lg <- sapply(sampleNames(gs), function(sn){
#'                                    gh <- gs[[sn]]
#'                                    dat <- exprs(gh_pop_get_data(gh, "cd3+"))#get events data matrix for this sample at cd3+ node
#'                                    vec <- dat[, "FSC-A"] > 1e4 & data[, "SSC-A"] > 1e5
#'                                    vec
#'                                    })
#'    gs_pop_add(gs, lg, name = "new_bool", parent = "cd3+")
#'  }
#' @param validityCheck \code{logical} whether to check the consistency of tree structure across samples. default is TRUE. Can be turned off when speed is prefered to the robustness.
#' @export 
gs_pop_add <- function(gs, gate, validityCheck = TRUE, ...){
  
  samples <- sampleNames(gs)
  if((is(gate, "filter")||is(gate, "filters")) && !is(gate, "filterResultList"))
    gate <- sapply(samples,function(x)return(gate))
  
  if(!setequal(names(gate),samples))
    stop("names of gate list do not match with the sample names in the gating set!")			
  
  nodeIDs <- lapply(samples,function(sample){
    curFilter <- gate[[sample]]
    gh <- gs[[sample]]
    #								browser()
    pop_add(curFilter, gh, ...)
  })
  
  nodeID <- nodeIDs[[1]]
  
  if(validityCheck){
    if(!all(sapply(nodeIDs[-1],function(x)isTRUE(all.equal(x, nodeID, check.attributes = FALSE))))){
      #restore the gatingset by removing added nodes
      mapply(samples, nodeIDs, FUN = function(sample, nodeID){
        gh <- gs[[sample]]
        nodes <- gs_get_pop_paths(gh)[nodeID]
        lapply(nodes, gh_pop_remove, gh = gh)
      })
      stop("nodeID are not identical across samples!")
    }
    
  }
  nodeID
}


                                                     
.addGate <- function(gh, filterObject, parent = "root", name = NULL, negated = FALSE, recompute = FALSE){
  if(recompute)
	  stop("'recompute = TRUE' is no longer supported by addGate!")
	if(is.null(name))
		name <- filterObject$filterId
    #replace the slash with colon 
    #since forward slash is reserved for gating path
  if(grepl("/",name)){
    old_name <- name
    name <- gsub("/",":",name)
    warning(old_name, " is replaced with ", name)
  }
    
	
	
	filterObject$negated <- negated
#	browser()	
    sn <- sampleNames(gh)
    
    ptr <- gh@pointer
	nodeID <- cpp_addGate( ptr, sn, filterObject, parent, name)
        
	nodeID+1
}

#' Add populations to a GatingHierarchy
#' 
#' @rdname pop_add
#' @export 
#' @param gate a gate object that extends \code{flowCore::filter} or \code{flowCore::filters}
#' @param gh GatingHierarchy
pop_add <- function(gate, gh,...)UseMethod("pop_add")

#' @rdname pop_add
#' @export 
pop_add.filter <- function(gate, gh,... )
		{
			.addGate(gh,filter_to_list(gate),...)
		}
#' @param names  a \code{character} vector of length four,which specifies the population names resulted by adding a \code{quadGate}.The order of the names is clock-wise starting from the top left quadrant population.   
#' @rdname pop_add
#' @export 
pop_add.filters <- function(gate, gh, names = NULL, ... )
    {
      if(!is.null(names))
      {
        if(any(duplicated(names)))
          stop("population names given by 'name` argument are not unqiue")
        if(length(names)!=length(gate))
          stop("number of population names (given by 'name' argument) does not agree with the number of filter objects in 'filters'!")
        
        unlist(mapply(gate, names, FUN = function(thisFilter, thisName){
          pop_add(thisFilter, gh, name = thisName, ...)
                })
        )
      }else
        unlist(lapply(gate, function(thisFilter)pop_add(thisFilter, gh, ...)))
      
    }

#' @rdname pop_add
#' @export 
pop_add.quadGate <- function(gate, gh, names = NULL, ... )
		{
			
			#convert to four recgates			
			params<-parameters(gate)
			fr <- gh_pop_get_data(gh, use.exprs = FALSE)
			desc<-sapply(params,function(x)getChannelMarker(fr,x)$des)
			fb <- filter_to_list(gate)			
			#clock-wise from top left quadrant
			if(is.null(names))
				names <- matrix(c(sprintf("%s-%s+", desc[1], desc[2]),
									sprintf("%s+%s+", desc[1], desc[2]),
									sprintf("%s+%s-", desc[1], desc[2]),
									sprintf("%s-%s-", desc[1], desc[2])
									),
								ncol=2)
			if(length(unique(names))!=4)
				stop("names have to be four unique strings!")
			
			unlist(lapply(1:4,function(i){
							fb1 <- c(fb, quad = i)
				            .addGate(gh,  fb1, name = names[i], ...)
						})
					)
			
			
			
		}


## it just contains the logical vector as indices generated by clustering algrorithm 
## like flowClust
#' @param name the population name
#' @param  parent a \code{character} scalar to specify the parent node name where the new gate to be added to, by default it is NULL,which indicates the root node
#' @param  recompute whether to recompute the gates
#' @param  cluster_method_name when adding the logical vectors as the gates, the name of the cluster method can be used to tag the populations as the extra meta information associated with the gates.
#' @param ... other arguments  
#' @rdname pop_add
#' @export 
pop_add.logical <- function(gate, gh, parent, name, recompute, cluster_method_name = NULL, ... )
          {
            
            
            #convert to global one by combining it with parent indice
			idx <- gh_pop_normalize_idx(gh, parent, gate)
	
              
            fb <- filter_to_list(idx)
            #update object when it is a clusterGate
            if(!is.null(cluster_method_name))
            {
              fb[["type"]] <- as.integer(8)
              fb[["cluster_method_name"]] <- cluster_method_name
            }
            #skip gating by ignoring recompute      
            nodeID <- .addGate(gh, fb, name = name, parent = parent, ...)
            
			.gh_pop_set_indices(gh, nodeID, idx)
          }

#' @rdname pop_add
#' @export 
pop_add.factor <- function(gate, gh, name = NULL, ...)
          {
            popNames <- levels(gate)
            if(is.null(name))
              stop("Must specify the name of the cluster method through 'name' argument")
            else
            {
              if(length(name) != 1)
                stop("'name' can't use multiple!")
            }
            for(i in seq_along(popNames)){
              
              thisPop <- popNames[i]
              
              pop <- paste(name, thisPop, sep = "_")
              
              # browser()
              #convert it to logical
              ind <- gate == thisPop
              ind[is.na(ind)] <- FALSE#in case there are some NA values in factor
              pop_add(ind, gh, name = pop, cluster_method_name = name, ...)
            }
          }

#' @rdname pop_add
#' @export 
pop_add.logicalFilterResult <- function(gate, gh, ... )
          {
            
            #fetch the indices from the fitler result
            gate <- gate@subSet
            pop_add(gate, gh, ...)
            
          }

#' @rdname pop_add
#' @export 
pop_add.multipleFilterResult <- function(gate, gh, name = NULL, ...)
          {
            popNames <- names(gate)
            if(!is.null(name)){
              if(length(name) != length(popNames))
                stop("name must be of the same length as the number of populations in multipleFilterResult!")
            }
            for(i in seq_along(popNames)){
              
              thisName <- name[i]
              thisPop <- popNames[i]
              if(is.null(thisName)){
                pop <- thisPop
              }else{
                pop <- thisName
              }
              pop_add(gate[[pop]], gh,  name = pop, ...)
            }
          }

#' @templateVar old Rm
#' @templateVar new gs_pop_remove
#' @template template-depr_pkg
NULL
#' @export 
#' @rdname gs_pop_add
gs_pop_remove <- function(gs, node, ...){
  invisible(lapply(gs,function(gh){
    #								browser()
    gh_pop_remove(gh, node, ...)
  }))
}
#' @export
Rm <- function(node, gs, ...)
		{
			.Deprecated("gs_pop_remove")
		  gs_pop_remove(gs, node, ...)
		}
   

#' @export 
#' @param node population name/path
#' @rdname pop_add
gh_pop_remove <- function(gh, node, ...)
{
  fast <- list(...)[["fast"]]
  if(!is.null(fast)&&!fast)
  {
    ##remove all children nodes as well
    childrenNodes <- gs_pop_get_children(gh,node)
        #use path instead of unqiue name since the prefix of unique name
        #will change during deletion
    lapply(childrenNodes,function(child)gh_pop_remove(gh, child, fast = FALSE))
        
    cpp_removeNode(gh@pointer,sampleNames(gh), node, FALSE)
  }else
    cpp_removeNode(gh@pointer,sampleNames(gh), node, TRUE)
}