R/add_pop.R

In openCyto: Hierarchical Gating Pipeline for flow cytometry data

# For keeping track of add_pop history
add_pop_history <- new.env(parent = emptyenv())
add_pop_history$records <- list()

#' @title Deprecated functions in package \pkg{openCyto}.
#' @templateVar old add_pop
#' @templateVar new gs_add_gating_method
#' @template template-depr_pkg
NULL
#' apply a gating method to the \code{GatingSet}
#' 
#' When interacting with the existing gated data, this function provides an alternative way to interact with the GatingSet 
#' by supplying the gating description directly through arguments without the need to write the complete
#' csv gating template. 
#' 
#' Calls to \code{gs_add_gating_method} can also be easily reversed with \code{\link{gs_remove_gating_method}}. Note, however, that it is not possible
#' to differentiate between different \code{GatingSet} objects loaded from the same directory with 
#' \code{\link[flowWorkspace]{load_gs}} within a session. Thus, to guarantee a clean history for \code{gs_remove_gating_method}, 
#' it is necessary to call \code{\link{gs_add_gating_method_init}} on the loaded \code{GatingSet} immediately after re-loading it. 
#' See the documentation for \code{\link{gs_add_gating_method_init}} for more details. 
#' This will not be an issue for \code{GatingSet} objects created directly using the constructor. 
#'      
#' @name gs_add_gating_method
#' @aliases add_pop
#' @param gs GatingSet or GatingSetList
#' @param alias,pop,parent,dims,gating_method,gating_args,collapseDataForGating,groupBy,preprocessing_method,preprocessing_args see details in \link[openCyto:gatingTemplate-class]{gatingTemplate}
#' @param strip_extra_quotes \code{logical} Extra quotes are added to strings by fread. This causes problems with parsing R strings to expressions in some cases. Default FALSE for usual behaviour. TRUE should be passed if parsing gating_args fails.
#' @param ... other arguments
#' \itemize{
#'      \item{mc.cores}{ passed to \code{multicore} package for parallel computing}
#'      \item{parallel_type}{  \code{character} specifying the parallel type. The valid options are "none", "multicore", "cluster".}
#'      \item{cl}{ \code{cluster} object passed to \code{parallel} package (when \code{parallel_type} is "cluster")}
#'      }
#' @seealso \code{\link{gs_remove_gating_method}} \code{\link{gs_add_gating_method_init}}
#' @examples 
#' \dontrun{
#' # add quad gates 
#' gs_add_gating_method(gs, gating_method = "mindensity", dims = "CCR7,CD45RA", parent = "cd4-cd8+", pop = "CCR7+/-CD45RA+/-")
#' 
#' # polyfunctional gates (boolean combinations of exsiting marginal gates)
#' gs_add_gating_method(gs, gating_method = "polyFunctions", parent = "cd8", gating_args = "cd8/IFNg:cd8/IL2:cd8/TNFa")
#' 
#' #boolGate method
#' gs_add_gating_method(gs, alias = "IL2orIFNg", gating_method = "boolGate", parent = "cd4", gating_args = "cd4/IL2|cd4/IFNg") 
#' }
#' @export
gs_add_gating_method <- function(gs, alias = "*"
                       , pop = "+"
                       , parent
                       , dims = NA
                       , gating_method
                       , gating_args = NA
                       , collapseDataForGating = NA
                       , groupBy = NA
                       , preprocessing_method = NA
                       , preprocessing_args = NA
                       , strip_extra_quotes = FALSE
                       , ...) {
  #still check this new pop                     
  .validity_check_alias(alias)
  
  #generate the dummy template based on the existing gating hierarchy
  dt <- as.data.table(gh_generate_template(gs[[1]]))
  pre_add_state <- gs_get_pop_paths(gs[[1]])
  
  if(nrow(dt)>0){
    #Can't use the existing dummy_gate since it is dedicated as dummy_ref gate generated by multiPos entry (alias = '*')
    #which requires the ref node to be explicitly supplied
    dt[, gating_method := "dummy"]
  }
  if(is.list(gating_args))
  {
    gating_args <- .argDeparser(gating_args)      
  }
  if(is.list(preprocessing_args))
  {
    preprocessing_args <- .argDeparser(preprocessing_args)      
  }
  
  thisRow <- data.table(alias = alias
                        , pop = pop
                        , parent = parent
                        , dims = dims
                        , gating_method = gating_method
                        , gating_args =  gating_args
                        , collapseDataForGating = collapseDataForGating
                        , groupBy = groupBy
                        , preprocessing_method = preprocessing_method
                        , preprocessing_args = preprocessing_args
  )
  if(nrow(thisRow)>1)
    stop("Can't add multiple rows!Please make sure each argument is of length 1.")
  #there's a weird bug where rbinding a 0-row dt and a non-zero row dt returns > 4M rows.
  if(nrow(dt)>0){       
    dt <- rbind(dt, thisRow)   
  }else{
    dt = thisRow
  }
  
  tmp <- tempfile(fileext = ".csv")
  write.csv(dt, tmp, row.names = F)
  
  #skip the validity check on the other entries
  # Pass ... to gatingTemplate to allow strip_extra_quotes to be passed
  suppressMessages(gt <- gatingTemplate(tmp, strict = FALSE,strip_extra_quotes = strip_extra_quotes))
  message("...")
  suppressMessages(gt_gating(gt, gs, ...))
  message("done")
  post_add_state <- gs_get_pop_paths(gs[[1]])
  
  ## Add records if everything succeeded
  # Find record for this gating set or create it if necessary
  if(!(identifier(gs) %in% names(add_pop_history$records))){
    add_pop_history$records[[identifier(gs)]] <- list()
    # Fresh record, so make the pre_add snapshot the first
    # Otherwise, it's already there from the last call to gs_add_gating_method)
    add_pop_history$records[[identifier(gs)]][[1]] <- pre_add_state
    
    ## If it's a GatingSetList, make this the first snapshot for each of its GatingSets if needed
    if(is(gs, "GatingSetList")){
      lapply(gs, function(x){
        if(!(identifier(x) %in% names(add_pop_history$records))){
          add_pop_history$records[[identifier(x)]] <- list()
          add_pop_history$records[[identifier(x)]][[1]] <- pre_add_state
        }
      })
    }
  }
  
  # Push on the new record
  add_pop_history$records[[identifier(gs)]][[length(add_pop_history$records[[identifier(gs)]])+1]] <- post_add_state
  
  # If it's a GatingSetList, push on the new record for each of its GatingSets
  if(is(gs, "GatingSetList")){
    lapply(gs, function(x){
      add_pop_history$records[[identifier(x)]][[length(add_pop_history$records[[identifier(x)]])+1]] <- post_add_state
    })
  }
  
  invisible(thisRow)
}

#' @export
add_pop <- function(gs, alias = "*"
                    , pop = "+"
                    , parent
                    , dims = NA
                    , gating_method
                    , gating_args = NA
                    , collapseDataForGating = NA
                    , groupBy = NA
                    , preprocessing_method = NA
                    , preprocessing_args = NA
                    , strip_extra_quotes = FALSE
                    , ...){
  .Deprecated("gs_add_gating_method")
  gs_add_gating_method(gs, alias, pop, parent, dims, gating_method
             , gating_args, collapseDataForGating, groupBy
             , preprocessing_method, preprocessing_args
             , strip_extra_quotes, ...)
}


#' @templateVar old add_pop_init
#' @templateVar new gs_add_gating_method_init
#' @template template-depr_pkg
NULL
#' Clear history of \code{gs_add_gating_method} calls for a given \code{GatingSet} or \code{GatingSetList}
#' 
#' Repeated calls to the \code{\link{load_gs}} method in the same session
#' will yield indistinguishable objects that can result in overlapping history
#' of \code{\link{gs_add_gating_method}} calls. This method allows for the history to be cleared
#' if the user would like to reload the \code{GatingSet} and start fresh. Calling
#' \code{gs_add_gating_method_init} without an argument will clear the entire \code{gs_add_gating_method} history.
#' 
#' @name gs_add_gating_method_init
#' @aliases add_pop_init
#' @usage 
#' gs_add_gating_method_init(gs)
#' @param gs a \code{GatingSet} or \code{GatingSetList}. Can be omitted to clean entire \code{gs_add_gating_method} history.
#' 
#' @examples
#' \dontrun{
#' # load in a GatingSet
#' gs <- load_gs(path)
#' # Add some nodes using gs_add_gating_method
#' gs_add_gating_method(gs, gating_method = "mindensity", dims = "CCR7,CD45RA", parent = "cd4-cd8+", pop = "CCR7+/-CD45RA+/-")
#' gs_add_gating_method(gs, gating_method = "polyFunctions", parent = "cd8", gating_args = "cd8/IFNg:cd8/IL2:cd8/TNFa")
#' # Remove the effect of the last gs_add_gating_method call using gs_remove_gating_method (note that the first call's effects remain)
#' gs_remove_gating_method(gs)
#' # Re-load the GatingSet to start over
#' gs <- load_gs(path)
#' 
#' # At this point, gs will still see the history of the first gs_add_gating_method call above
#' # which will cause problems for later calls to gs_remove_gating_method.
#' # To fix that, just call gs_add_gating_method_init() to start a clean history
#' gs_add_gating_method_init(gs)
#' # Now you can continue using gs_add_gating_method and gs_remove_gating_method from scratch
#' gs_add_gating_method(gs, gating_method = "mindensity", dims = "CCR7,CD45RA", parent = "cd4-cd8+", pop = "CCR7+/-CD45RA+/-")
#' }
#' 
#' @export
gs_add_gating_method_init <- function(gs = NULL){
  if(!is.null(gs)){
    if(is(gs, "GatingSetList")){
      lapply(gs, function(x) add_pop_history$records[[identifier(x)]] <- NULL)
    }
    add_pop_history$records[[identifier(gs)]] <- NULL
  }else{
    add_pop_history$records <- list() 
  }
}

#' @export
add_pop_init <- function(gs = NULL){
  .Deprecated("gs_add_gating_method_init")
  gs_add_gating_method_init(gs)
}