#' A graph object returned by 'read.gatingML.cytobank' function.
#'
#' Each node corresponds to a population(or GateSet) defined in gatingML file. The actual gate object (both global and tailored gates) is
#' associated with each node as nodeData. Compensation and transformations are stored in graphData slot.
#'
#' The class simply extends the graphNEL class and exists for the purpose of method dispatching.
#'
#' @importClassesFrom graph graphNEL graphBase graph
#' @importClassesFrom Biobase AssayData
setClass("graphGML", contains = "graphNEL")
#' Parser for gatingML exported by Cytobank
#'
#' The Default parser (read.gatingML) does not parse the population tree as well as
#' the custom information from cytobank. (e.g. gate name, fcs filename).
#'
#' @param file Gating-ML XML file
#' @param ... additional arguments passed to the handlers of 'xmlTreeParse'
#' @importFrom flowCore parameters parameters<-
#' @importFrom methods is
#' @return a graphGML that represents the population tree.
#' The gate and population name are stored in nodeData of each node.
#' Compensation and transformations are stored in graphData.
#' @examples
#' \dontrun{
# acsfile <- system.file("extdata/cytobank_experiment.acs", package = "CytoML")
# ce <- open_cytobank_experiment(acsfile)
# xmlfile <- ce$gatingML
#' g <- read.gatingML.cytobank(xml) #parse the population tree
#' #plot(g) #visualize it
#' }
read.gatingML.cytobank <- function(file, ...){
#parse all the elements:gate, GateSets, comp, trans
flowEnv <- new.env()
suppressWarnings(read.gatingML(file, flowEnv))#suppress the deprecated warnings from XML
#parse gate info (id vs fcs and pop name)
gateInfo <- parse.gateInfo(file)
if(nrow(gateInfo) == 0)
stop("No gates defined in gatingML file!")
#restore the original gate parameter names
#because flowUtils add comp and tran names as prefix which is really not neccessary (even problematic) here.
for(objID in ls(flowEnv)){
obj <- flowEnv[[objID]]
if(methods::is(obj, "parameterFilter")){
# message(class(obj))
sb <- gateInfo[id == objID, ]
if(nrow(sb)>0){
orig_params <- sb[, params]
orig_params <- strsplit(split = ":", orig_params)[[1]]
params <- parameters(obj)
ind <- unlist(sapply(orig_params, function(orig_param)grep(paste0("\\Q", orig_param, "\\E$"), params)))
if(length(ind)==0)
stop("orig_param : '", paste(orig_params, collapse = ","), "'\n not matched to the prefixed params of the gate: \n'", paste(params, collapse = ","), "'")
orig_param <- orig_params[ind]
#cytobank add Comp_ prefix when the custom compensation is specified and referred by gates
#We always strip it to ensure the bare channel names are used for gates (so that flow data does not need changes)
orig_param <- sub("(^Comp_)(.*)", "\\2", orig_param)
parameters(obj) <- orig_param
flowEnv[[objID]] <- obj
}
}
}
#construct tree from GateSets
g <- constructTree(flowEnv, gateInfo)
#determine comps and trans to be used
comp_refs <- gateInfo[, comp_ref]
comp_refs <- unique(comp_refs[comp_refs!=""])
comp_refs <- comp_refs[comp_refs != "uncompensated"]
if(length(comp_refs) == 0)
comps <- "NONE"
else if(length(comp_refs) > 1)
stop("More than one compensation referred in gates!")
else{
if(comp_refs == "FCS")
comps <- "FCS"
else{
comps <- flowEnv[[comp_refs]]
#strip Comp_ prefix that was added by cytobank
# mat <- comps@spillover
# comp_param <- colnames(mat)
# comp_param <- sapply(comp_param, function(i)sub("(^Comp_)(.*)", "\\2", i), USE.NAMES = FALSE)
# colnames(mat) <- comp_param
# comps <- compensation(mat)
}
}
g@graphData[["compensation"]] <- comps
trans <- sapply(ls(flowEnv), function(i){
obj <- flowEnv[[i]]
#exclude the compensatedParameter since it also inherits transformation class
if(methods::is(obj, "transformation")&&!methods::is(obj, "compensatedParameter"))
obj
}, USE.NAMES = FALSE)
trans <- compact(trans)
chnl <- sapply(trans, function(tran)unname(parameters(tran@parameters)), USE.NAMES = FALSE)
ind <- chnl != "any"
chnl <- chnl[ind]
trans <- trans[ind]
names(trans) <- chnl
if(length(trans) > 0)
g@graphData[["transformations"]] <- trans
methods::as(g, "graphGML")
}
#' Parse the cytobank custom_info for each gate
#'
#' Fcs filename and gate name stored in 'custom_info' element are beyong the scope of
#' the gatingML standard and thus not covered by the default 'read.gatingML'.
#'
#' @param file xml file path
#' @param ... additional arguments passed to the handlers of 'xmlTreeParse'
#' @return a data.frame that contains three columns: id (gateId), name (gate name), fcs (fcs_file_filename).
#' @importFrom XML xmlRoot xmlName xmlGetAttr xmlValue xmlElementsByTagName xmlChildren
#' @import data.table
parse.gateInfo <- function(file, ...)
{
root <- xmlRoot(smartTreeParse(file,...))
rbindlist(
lapply(xmlChildren(root), function(node){
nodeName <- xmlName(node)
if(grepl("*Gate", nodeName)){
id <- xmlGetAttr(node, "id")
name <- getCustomNodeInfo(node, "name")
fcs_file_filename <- getCustomNodeInfo(node, "fcs_file_filename")
fcs_file_id <- getCustomNodeInfo(node, "fcs_file_id")
gate_id <- getCustomNodeInfo(node, "gate_id")#used to find tailored gate
if(nodeName %in% c("BooleanGate"))
{
gate_def <- comp_ref <- trans_ref <- params <- ""
}else
{
gate_def <- getCustomNodeInfo(node, "definition")
if(nodeName == "QuadrantGate"){
dimTag <- "divider"
#update id with quardant definition
quadrantList <- xmlElementsByTagName(node, "Quadrant")
id <- unname(sapply(quadrantList, function(i)xmlGetAttr(i, "id")))
}else
dimTag <- "dimension"
dimNode <- xmlElementsByTagName(node, dimTag)
comp_ref <- unique(sapply(dimNode, function(i)xmlGetAttr(i, "compensation-ref")))
comp_ref <- comp_ref[comp_ref != "uncompensated"]
if(length(comp_ref)==0)
comp_ref <- ""
else if(length(comp_ref) > 1)
stop(name, " gate is associated with multiple compensations: ", paste(comp_ref, collapse = ","))
trans_ref <- unique(unname(unlist(compact(sapply(dimNode, function(i)xmlGetAttr(i, "transformation-ref"))))))
trans_ref <- ifelse(is.null(trans_ref), "", trans_ref)
params <- paste(sapply(dimNode, function(i)xmlGetAttr(i[["fcs-dimension"]], "name")), collapse = ":")
}
# message(name)
# browser()
data.table(id = id, name = name, gate_id = gate_id, fcs = fcs_file_filename, fcs_file_id = fcs_file_id
, comp_ref = comp_ref, trans_ref = trans_ref, params = params, gate_def = gate_def
)
}
})
)
}
getCustomNodeInfo <- function(node, nodeName){
custom_node <- xmlElementsByTagName(node, nodeName, recursive = TRUE)
if(length(custom_node) >0 ){
value <- xmlValue(custom_node[[1]])
if(length(value)==0)
value <- ""
}
else
value <- ""
value
}
#' Given the leaf node, try to find out if a collection of nodes can be matched to a path in a graph(tree) by the bottom-up searching
#' @param g graphNEL
#' @param leaf the name of leaf(terminal) node
#' @param nodeSet a set of node names
#' @return TRUE if path is found, FALSE if not path is matched.
#' @importFrom graph inEdges
matchPath <- function(g, leaf, nodeSet){
if(leaf %in% nodeSet){
nodeSet <- nodeSet[-match(leaf, nodeSet)] #pop it out
leaf <- inEdges(leaf, g)[[1]]#update it with parent node
if(length(nodeSet) == 0){ #nodeSet emptied
if(length(leaf) == 0) #and path reach to the top
return (TRUE)
else
return(FALSE) #path has not reached to the top
}else
{
if(length(leaf) == 0) #reach the top before nodeSet is emptied
return(FALSE)
else
matchPath(g, leaf, nodeSet) #continue match the path against nodeSet
}
}else
return(FALSE)
}
#' Reconstruct the population tree from the GateSets
#' @param flowEnv the enivornment contains the elements parsed by read.gatingML function
#' @param gateInfo the data.frame contains the gate name, fcs filename parsed by parse.gateInfo function
#' @return a graphNEL represent the population tree. The gate and population name are stored as nodeData in each node.
#' @importFrom graph graphNEL nodeDataDefaults<- nodeData<- addEdge edges removeNode addNode
#' @importFrom jsonlite fromJSON
#' @importFrom methods slot
constructTree <- function(flowEnv, gateInfo){
#parse the references from boolean gates
#currently we use refs (which point to the gate id defined by the standard)
#we don't want to use gate_id from custom_info used by cytobank internally
#because quadrantGate seems do not have this id for each of its quadrant elements
gateSets <- sapply(ls(flowEnv), function(i){
obj <- flowEnv[[i]]
if(class(obj) == "intersectFilter"){
refs <- obj@filters
refs <- sapply(refs, methods::slot, "name")
unique(refs) #make root node depth of 1
}
})
gateSets <- compact(gateSets)
if(length(gateSets) == 0)
stop("No GateSets defined in gatingML file!")
popIds <- names(gateSets)
#sort by the depths of path
counts <- sapply(gateSets, function(i)length(i))
counts <- sort(counts)
#init the graph with all gates that have been referred
# gateIds <- unique(unlist(gateSets))
g <- graphNEL(nodes = popIds, edgemode = "directed")
nodeDataDefaults(g, "popName") <- ""
nodeDataDefaults(g, "gateInfo") <- list()
# add edges (from nDepths 2 to n)
for(popId in names(counts)){
thisGateSet <- gateSets[[popId]]
nDepth <- length(thisGateSet)
popName <- gateInfo[id == popId, name]
#add pop name
nodeData(g, popId, "popName") <- popName
message(popName)
if(nDepth == 1){#root node
gateID <- thisGateSet[1]
g <- addGate(gateInfo,flowEnv, g, popId, gateID)
}else{
#traverse all the potential parent GateSets(i.e. subset)
#must go all the way up to the root
#because the difference between parent and current node could be more than level 1
for(pDepth in (nDepth - 1):1){
parents_popIds <- names(counts[counts == pDepth])
matchRes <- findParent(gateSets, thisGateSet, parents_popIds)
if(!is.null(matchRes))
break
}
parentID <- matchRes[["parentID"]]
gateIDs <- matchRes[["gateIDs"]]
#when length(gateIDs) > 1, then we need to add each gate as a separate pop
#even though some of these gates do not have GateSet defined in gatingML
for(i in 1:length(gateIDs)){
gateID <- gateIDs[i]
if(i < length(gateIDs)){
#need to create the new pop that is not currently defined in gatingML GateSets
thisPopId <- gateID #use gateID as popID, which can not be found in gate_info
#add new pop
g <- addNode(thisPopId, g)
thisGateName <- gateInfo[id == gateID, name]
nodeData(g, thisPopId, "popName") <- paste0(thisGateName, "_0")
g <- addEdge(parentID, thisPopId, g)
g <- addGate(gateInfo,flowEnv, g, thisPopId, gateID)
parentID <- thisPopId #update the parent
}else{
thisPopId <- popId
g <- addEdge(parentID, thisPopId, g)
g <- addGate(gateInfo,flowEnv, g, thisPopId, gateID)
}
}
}
}
#prune the tree by removing the orphan nodes
# egs <- edges(g)
# leaves <- names(egs[sapply(egs, length) == 0])
# for(node in leaves){
# if(length(inEdges(node, g)[[1]]) == 0)
# g <- removeNode(node, g)
# }
g
}
findParent <- function(gateSets,thisGateSet, parents_popIds){
isFound <- FALSE
for(parentID in parents_popIds)
{
pGateSet <- gateSets[[parentID]]
#check the overlaps between two sets
if(setequal(intersect(pGateSet, thisGateSet), pGateSet))
{
isFound <- TRUE
#if it is indeed a subset of the current gateSet
gateIDs <- setdiff(thisGateSet, pGateSet) #parse out the gateID
# There might be multiple parents due to the duplicated GateSets allowed in gatingML
# it is not clear which one should be picked and
# we pick the first one for now
break
}
}
if(isFound)
return(list(parentID = parentID, gateIDs = gateIDs))
else
return(NULL)
}
addGate <- function(gateInfo,flowEnv, g, popId, gateID){
#add gate
sb <- gateInfo[id == gateID, ]
nGates <- nrow(sb)
if(nGates > 1)
stop("multiple gates found for ", gateID)
#try to find the tailored gate
tg_sb <- gateInfo[gate_id == sb[, gate_id] & fcs != "", ]
tg_gateid <- tg_sb[, id]
tg <- sapply(tg_gateid, function(gateID){
flowEnv[[gateID]]
}, simplify = FALSE)
#create index by both fcs name and fcs file id in case the input file is named by either
fcs_vs_gateid <- tg_gateid
names(fcs_vs_gateid) <- tg_sb[, fcs]
fileid_vs_gateid <- tg_gateid
names(fileid_vs_gateid) <- tg_sb[, fcs_file_id]
# message(popName)
gate <- flowEnv[[gateID]]
#parse bounding info
cytobank_gate_def <- fromJSON(sb[, gate_def])
# if(gateID == "Gate_2095590_UEQtMShIaXN0byk.")
# browser()
pname <- parameters(gate)
if(length(pname) == 1){
bound <- cytobank_gate_def[["scale"]][c("min", "max")]
bound <- t(as.matrix(bound))
rownames(bound) <- pname
}
else
bound <- t(sapply(c("x", "y"), function(axis){
cytobank_gate_def[["scale"]][[axis]][c("min", "max")]
}))
rownames(bound) <- as.vector(parameters(gate))
nodeData(g, popId, "gateInfo") <- list(list(gate = gate
, gateName = sb[, name]
, tailored_gate = list(gateid_vs_gate = tg
, file_vs_gateid = c(fcs_vs_gateid, fileid_vs_gateid)
)
, bound = bound
)
)
g
}
#' extend the gate to the minimum and maximum limit of both dimensions based on the bounding information.
#'
#' It is equivalent to the behavior of shifting the off-scale boundary events into the gate boundary that is describled in
#' bounding transformation section of gatingML standard.
#'
#' The advantage of extending gates instead of shifting data are two folds:
#' 1. Avoid the extra computation each time applying or plotting the gates
#' 2. Avoid changing the data distribution caused by adding the gates
#'
#' Normally this function is not used directly by user but invoked when parsing GatingML file exported from Cytobank.
#'
#' @export
#' @param gate a flowCore filter/gate
#' @param bound numeric matrix representing the bouding information parsed from gatingML. Each row corresponds to a channel.
#' rownames should be the channel names. colnames should be c("min", "max")
#' @param data.range numeric matrix specifying the data limits of each channel. It is used to set the extended value of vertices and must has the same structure as 'bound'.
#' when it is not supplied, c(-.Machine$integer.max, - .Machine$integer.max) is used.
#' @param limits character whether to plot in "extended" or "original" gate limits. Default is "original".
#' @param ... other arguments
#' @return a flowCore filter/gate
#' @examples
#' library(flowCore)
#' sqrcut <- matrix(c(300,300,600,600,50,300,300,50),ncol=2,nrow=4)
#' colnames(sqrcut) <- c("FSC-H","SSC-H")
#' pg <- polygonGate(filterId="nonDebris", sqrcut)
#' pg
#' bound <- matrix(c(100,3e3,100,3e3),
#' byrow = TRUE, nrow = 2,
#' dimnames = list(c("FSC-H", "SSC-H"),
#' c("min", "max")))
#' bound
#' pg.extened <- extend(pg, bound, plot = TRUE)
extend <- function(gate, bound, data.range = NULL, plot = FALSE, limits = c("original", "extended"))UseMethod("extend")
#' @export
#' @rdname extend
#' @param plot whether to plot the extended polygon.
#' @importFrom flowCore polygonGate
#' @importFrom graphics abline polygon text
#' @importFrom grDevices rgb
extend.polygonGate <- function(gate, bound, data.range = NULL, plot = FALSE, limits = c("original", "extended")){
limits <- match.arg(limits)
#linear functions
f.solve <- list(x = function(x, slope, x1, y1){
res <- slope * (x - x1) + y1
names(res) <- "y"
res
}
,y = function(y, slope, x1, y1){
res <- (y - y1) / slope + x1
names(res) <- "x"
res
}
)
#update chnnl names with generic axis names
chnls <- as.vector(rownames(bound))
axis.names <- c("x", "y")
rownames(bound) <- axis.names
verts.orig <- gate@boundaries
#fix Inf (from rectangleGate)
verts.orig[verts.orig==Inf] <- .Machine$integer.max
verts.orig[verts.orig==-Inf] <- -.Machine$integer.max
#this is a hack: We assume the polygon is convex
#if not we turn the convcave into convex
#to avoid the error
# verts.orig <- verts.orig[chull(verts.orig),]
verts <- data.table(verts.orig)
pname <- as.vector(parameters(gate))
setnames(verts, colnames(verts), pname)
ind <- match(pname, chnls)
new.name <- axis.names[ind]
setnames(verts, pname, new.name)
if(is.null(data.range)){
data.range <- data.frame(min = c(-.Machine$integer.max, - .Machine$integer.max)
, max = c(.Machine$integer.max, .Machine$integer.max)
, row.names = c("x", "y")
)
}else{
rname <- rownames(data.range)
ind <- match(rname, chnls)
rownames(data.range) <- axis.names[ind]
}
#accumulatively update verts by detecting and inserting the intersection points
#removing off-bound vertex points and inserting extended points
#for each boundary line
for(dim in axis.names){ #loop from x to y
for(bn in colnames(bound)){# loop from min to max
#extend data.range with gate range in case the later is larger
if(bn=="min")
data.range[dim, bn] <- min(data.range[dim, bn], min(verts[, ..dim]))
else
data.range[dim, bn] <- max(data.range[dim, bn], max(verts[, ..dim]))
intersect.coord <- bound[dim, bn][[1]]
names(intersect.coord) <- dim
nVerts <- nrow(verts)
# centroid <- colMeans(verts)
this.intersect <- lapply(1:nVerts, function(i){ #loop through each edge
#get two vertices
j <- ifelse(i == nVerts, 1, i + 1)
#get coordinates
y2 <- verts[j, y]
x2 <- verts[j, x]
y1 <- verts[i, y]
x1 <- verts[i, x]
#compute the slope
slope <- (y2 - y1) / (x2 - x1)
#get ranges
rg <- list(x = range(c(x1,x2)), y = range(c(y1,y2)))
this.rg <- rg[[dim]]
# points(x1, y1, col = "green")
# points(x2, y2, col = "blue")
#find inersect point
# message(i)
# if(i == 3)
if(intersect.coord <= this.rg[2]&&intersect.coord >= this.rg[1]){
#take care of horizontal/vertical edges
if(is.infinite(slope)){#vertical edge
if(dim == "x")
return(NULL) #parallel to vertical bound, no intersect
else
point <- c(x = x1, intersect.coord)
}else if(slope == 0){ #horizontal edge
if(dim == "y")
return(NULL)
else
point <- c(intersect.coord, y = y1)
}else{
#otherwise use linear function to compute the x or y coordinate
thisFun <- f.solve[[dim]]
# get the y axis of the intersected point
res <- thisFun(intersect.coord, slope, x1, y1)
# browser()
names(intersect.coord) <- dim
point <- c(intersect.coord, res)[axis.names]
}
c(point, id = i + 0.1)#jitter a positive ammount to break the tie with vert1
}
})
this.intersect.df <- do.call(rbind, this.intersect)
dim.flip <- ifelse(dim == "x", "y", "x")
# this.intersect <- this.intersect[order(this.intersect[[dim.flip]]),] #bottom to top/or left to right
nCount <- ifelse(is.null(this.intersect.df), 0, nrow(this.intersect.df))
if(nCount > 0){
if(nCount %% 2 != 0)
stop("uneven number of intersected points with ", bn, " boundary on ", dim, " axis: ", nCount)
verts[, id := 1:nVerts]#record the id before insertion
verts[, key := paste0(x,",", y)] # generate key for the comparsion to intersected points later on
#reset id for the duplicated intersects so that they won't cause chaos for the ordering later on
this.intersect.df <- as.data.table(this.intersect.df)
this.intersect.df[, key := paste0(x,",", y)]
this.intersect.df[, id := min(id), by = key]
#order by dim so that extension to pairs follows the order
setorderv(this.intersect.df, dim.flip)
inserted.ids <- NULL
#loop through each pair of extended points
for(i in seq_len(nCount/2)){
j <- 2 * i
# browser()
this.intersect <- this.intersect.df[(j -1):j, ]
# this.intersect <- as.data.table(this.intersect)
#remove the original edge points that overlap with intersect points
#but keep the intersected points inserted previously
#nchar(id) : length of significant digits
#== 1: original points
#== 2: intersected
#== 4: extended
# verts <- verts[!(key %in% this.intersect[, key] && nchar(id) == 1), ]
verts <- verts[!(key %in% this.intersect[, key]), ]
#keep track of id that has been inserted repeatly
#so that the duplicated intersects can be removed later
#otherwise, it could mess up the already removed off-bound points
dup.id <- this.intersect[id %in% inserted.ids, id]
inserted.ids <- unique(c(inserted.ids, this.intersect[, id]))
#insert the intersect points
verts <- rbindlist(list(verts, this.intersect))
verts <- verts[order(id),]
#remove off-bound points
#(no longer do it:between the two intersected points
#because sometime the points fall outside of the range of dim.flip of intersected points
#breaks the ordering assumption of two extended points)
vals.dim <- verts[, dim, with = FALSE]
vals.dim.flip <- verts[, dim.flip, with = FALSE]
rng.dim.flip <- range(this.intersect[[dim.flip]])
# ind.between <- vals.dim.flip <= rng.dim.flip[2] & vals.dim.flip >= rng.dim.flip[1]
if(bn == "min")
{
ind <- vals.dim < intersect.coord #& ind.between
}else
{
ind <- vals.dim > intersect.coord #& ind.between
}
ind <- as.vector(ind)
verts <- verts[!ind, ]
#add extended points
this.extend <- this.intersect
this.extend[, dim] <- data.range[dim, bn]
this.extend[, key := paste0(x,",", y)]#update key
#sort by the Id
this.extend[, is.smaller:= order(id) == 1]
#check if head-tail node situation
# by cal the distance between two points
this.extend[, order := match(id, verts[,id])]
dist <- abs(diff(this.extend[, order]))
if(dist == 1){#two consecutive points
this.extend[is.smaller == TRUE, id := id + 0.01]
this.extend[is.smaller == FALSE, id := this.extend[is.smaller == TRUE, id] + 0.01]
}else{
#deal with head-tail points
this.extend[is.smaller == TRUE, id := id - 0.01]
this.extend[is.smaller == FALSE, id := this.extend[is.smaller == TRUE, id] - 0.01]
}
# browser()
this.extend[, is.smaller := NULL]
this.extend[, order := NULL]
#remove dup id
verts <- verts[!id%in%dup.id, ]
verts <- rbindlist(list(verts, this.extend))
verts <- verts[order(id),]
}#end loop for each pair of intersects
#also make sure to remove the off-bound points outside of any intersected points range
vals.dim <- verts[, dim, with = FALSE]
vals.dim.flip <- verts[, dim.flip, with = FALSE]
rng.dim.flip <- range(this.intersect.df[[dim.flip]])
ind.between <- vals.dim.flip <= rng.dim.flip[2] & vals.dim.flip >= rng.dim.flip[1]
if(bn == "min")
ind <- vals.dim < intersect.coord & !ind.between
else
ind <- vals.dim > intersect.coord & !ind.between
ind <- as.vector(ind)
verts <- verts[!ind, ]
}#end if of ncount>0
}#end of inner for loop for boundary (from min to max)
}#end of outer for loop for dim (from x to y)
# if(isTRUE(parent.frame(1)[["popName"]] == "T-helpers"))
# browser()
if(plot){
if(limits == "extended")
plot(type = "n", x = verts[[1]], y = verts[[2]])
else
plot(type = "n", x = verts.orig[,1], y = verts.orig[,2])
polygon(verts.orig, lwd = 4, border = grDevices::rgb(0, 0, 0,0.5))
# points(verts.orig, col = "red")
# points(t(as.data.frame(colMeans(verts.orig))), col = "red")
# abline(v = bound[1,], lty = "dashed", col = "red")
# abline(h = bound[2,], lty = "dashed", col = "red")
text(verts, labels = verts[, id], col = "red")
# points(intersect.points[, c(axis.names)], col = "blue")
polygon(verts, lty = "dotted", border = "green", lwd = 3)
}
verts <- verts[, new.name, with = FALSE]
setnames(verts, new.name, chnls)
polygonGate(verts)
}
#' @export
#' @rdname extend
#' @importFrom flowCore rectangleGate
extend.rectangleGate <- function(gate, ...){
pnames <- parameters(gate)
nParam <- length(pnames)
if(nParam == 2){
gate <- fix.rectangleGate(gate)
extend(methods::as(gate, "polygonGate"), ...)
}else{
extend.rectangleGate1d(gate, ...)
}
}
extend.rectangleGate1d <- function(gate, bound, data.range = NULL)
{
if(is.null(data.range))
data.range <- c(min = -.Machine$integer.max, max= .Machine$integer.max)
if(gate@min <= bound[, "min"][[1]])
gate@min <- data.range["min"]
if(gate@max >= bound[, "max"][[1]])
gate@max <- data.range["max"]
gate
}
#' @export
#' @rdname extend
#' @importFrom flowCore ellipsoidGate
#' @importFrom methods as
extend.ellipsoidGate <- function(gate, ...){
#fix the ellipsoidGate parsed from gatingML
gate <- fix.ellipsoidGate(gate)
extend(methods::as(gate, "polygonGate"), ...)
}
fix.ellipsoidGate <- function(gate){
pnames <- as.vector(parameters(gate))
dimnames(gate@cov) <- list(pnames,pnames)
names(gate@mean) <- pnames
gate
}
fix.rectangleGate <- function(gate){
pnames <- parameters(gate)
names(gate@min) <- pnames
names(gate@max) <- pnames
gate
}
