# This file was copied from the flowUtils package on 5/6/2019.
# This represents the work of Josef Spidlen and the other flowUtils
# authors who are also accordingly credited in the authors list for CytoML.
#
# Details:
# https://github.com/jspidlen/flowUtils/
# GitHub version: 1.35.8
# Bioconductor version: 1.49.0
#############################################
## Code related to writing Gating-ML files ##
#############################################
# NOTE: If somebody has the time, it may be nice to
# rewrite this in an object-oriented fashion :-)
# Write objects in the flowEnv environment to an Gating-ML 2.0 XML file.
# If file is NULL then output is written to standard output.
write.gatingML <- function(flowEnv, file = NULL)
{
if(!is.null(file) && !is(file, "character"))
stop("A file has to be either NULL or a character string.", call. = FALSE)
if(is.null(flowEnv) || !is.environment(flowEnv))
stop("A flowEnv environment with objects to be saved is requred.", call. = FALSE)
if(!is.null(file) && substr(file, nchar(file) - 3, nchar(file)) != ".xml")
file <- paste(file, "xml", sep=".")
flowEnv[['.debugMessages']] = c()
namespaces <- c(
"gating" = "http://www.isac-net.org/std/Gating-ML/v2.0/gating",
"xsi" = "http://www.w3.org/2001/XMLSchema-instance",
"transforms" = "http://www.isac-net.org/std/Gating-ML/v2.0/transformations",
"data-type" = "http://www.isac-net.org/std/Gating-ML/v2.0/datatypes")
gatingMLNode = suppressWarnings(xmlTree("gating:Gating-ML", namespaces = namespaces,
attrs = c("xsi:schemaLocation" = "http://www.isac-net.org/std/Gating-ML/v2.0/gating http://flowcyt.sourceforge.net/gating/2.0/xsd/Gating-ML.v2.0.xsd http://www.isac-net.org/std/Gating-ML/v2.0/transformations http://flowcyt.sourceforge.net/gating/2.0/xsd/Transformations.v2.0.xsd http://www.isac-net.org/std/Gating-ML/v2.0/datatypes http://flowcyt.sourceforge.net/gating/2.0/xsd/DataTypes.v2.0.xsd")))
gatingMLNode$addNode("data-type:custom_info", close = FALSE)
gatingMLNode$addNode("info", "Gating-ML 2.0 export generated by R/flowCore/CytoML")
gatingMLNode$addNode("R-version", sessionInfo()$R.version$version.string)
gatingMLNode$addNode("flowCore-version", as.character(packageVersion("flowCore")))
gatingMLNode$addNode("CytoML-version", as.character(packageVersion("CytoML")))
gatingMLNode$addNode("XML-version", as.character(packageVersion("XML")))
gatingMLNode$closeTag()
flowEnv[['.objectIDsWrittenToXMLOutput']] = list() # Use this list to collect XML Ids
somethingUseful = FALSE
for (x in ls(flowEnv)) {
object = objectNameToObject(x, flowEnv)
if(is(object, "parameterFilter") || is(object, "singleParameterTransform") || is(object, "setOperationFilter"))
{
somethingUseful = TRUE
break
}
}
if(!somethingUseful) warning("Nothing useful seems to be present in the environment; the output Gating-ML file may not be very useful.", call. = FALSE)
# Go over everything and temporarily add transformations and argument gates to flowEnv
# if they are not saved in flowEnv directly, but they are being used in other objects
flowEnv[['.addedObjects']] = list() # List of object identifiers of objects that we have to temporarily add to flowEnv
for (x in ls(flowEnv)) addReferencedObjectsToEnv(x, flowEnv)
flowEnv[['.singleParTransforms']] = new.env() # Use this env to collect transformations
for (x in ls(flowEnv)) if(is(flowEnv[[x]], "singleParameterTransform")) collectTransform(x, flowEnv)
# Transforms go first unless they can be skipped all together
for (x in ls(flowEnv)) if(is(flowEnv[[x]], "transform"))
if(!shouldTransformationBeSkipped(x, flowEnv)) addObjectToGatingML(gatingMLNode, x, flowEnv)
for (x in ls(flowEnv)) if(!is(flowEnv[[x]], "transform")) addObjectToGatingML(gatingMLNode, x, flowEnv)
if(!is.null(file)) sink(file = file)
cat(saveXML(gatingMLNode$value(), encoding = "UTF-8"))
if(!is.null(file)) sink()
rm(list = ls(flowEnv[['.singleParTransforms']], all.names = TRUE), envir = flowEnv[['.singleParTransforms']])
rm('.singleParTransforms', envir = flowEnv)
rm(list = as.character(flowEnv[['.addedObjects']]), envir = flowEnv)
rm('.addedObjects', envir = flowEnv)
rm('.objectIDsWrittenToXMLOutput', envir = flowEnv)
}
# Add the object x to the Gating-ML node
addObjectToGatingML <- function(gatingMLNode, x, flowEnv, addParent = NULL, forceGateId = NULL)
{
if(is(x, "character")) object = flowEnv[[x]]
else object = x
switch(class(object),
"rectangleGate" = addRectangleGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"polygonGate" = addPolygonGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"ellipsoidGate" = addEllipsoidGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"quadGate" = addQuadGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"intersectFilter" = addBooleanAndGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"unionFilter" = addBooleanOrGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"complementFilter" = addBooleanNotGateNode(gatingMLNode, x, flowEnv, addParent, forceGateId),
"subsetFilter" = addGateWithParent(gatingMLNode, x, flowEnv),
"compensation" = addCompensation(gatingMLNode, x, flowEnv),
"asinhtGml2" = addAsinhtGml2(gatingMLNode, x, flowEnv),
"hyperlogtGml2" = addHyperlogtGml2(gatingMLNode, x, flowEnv),
"lintGml2" = addLintGml2(gatingMLNode, x, flowEnv),
"logtGml2" = addLogtGml2(gatingMLNode, x, flowEnv),
"logicletGml2" = addLogicletGml2(gatingMLNode, x, flowEnv),
"ratiotGml2" = addRatiotGml2(gatingMLNode, x, flowEnv),
"ratio" = addRatioGml1.5(gatingMLNode, x, flowEnv),
"asinht" = addAsinhtGml1.5(gatingMLNode, x, flowEnv),
"compensatedParameter" = NA,
"unitytransform" = NA,
"numeric" = NA,
{
errMessage <- paste("Class \'", class(object), "\' is not supported in Gating-ML 2.0 output.", sep="")
if(is(object, "singleParameterTransform"))
errMessage <- paste(errMessage, " Only Gating-ML 2.0 compatible transformations are supported by Gating-ML 2.0 output. Transformation \'",
object@transformationId, "\' is not among those and cannot be included. Therefore, any gate referencing this transformation would be referencing a non-existent transformation in the Gating-ML output. Please correct the gates and transformations in your environment and try again.", sep="")
if(is(object, "filter"))
errMessage <- paste(errMessage, " Only Gating-ML 2.0 compatible gates are supported by Gating-ML 2.0 output. Filter \'",
object@filterId, "\' is not among those and cannot be included. Please remove this filter and any references to it from the environment and try again.", sep="")
stop(errMessage, call. = FALSE)
}
)
}
# Add rectangle gate x to the Gating-ML node
addRectangleGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "rectangleGate")) stop(paste("Unexpected object insted of a rectangleGate - ", class(gate)))
addDebugMessage(paste("Working on rectangleGate ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:RectangleGate", attrs = attrs, close = FALSE)
addDimensions(gatingMLNode, x, flowEnv)
gatingMLNode$closeTag() # </gating:RectangleGate>
}
# Add polygon gate x to the Gating-ML node
addPolygonGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "polygonGate")) stop(paste("Unexpected object insted of a polygonGate - ", class(gate)))
addDebugMessage(paste("Working on polygonGate ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:PolygonGate", attrs = attrs, close = FALSE)
addDimensions(gatingMLNode, x, flowEnv)
for (i in 1:length(gate@boundaries[,1]))
{
gatingMLNode$addNode("gating:vertex", close = FALSE)
# attrs = c("data-type:value" = gate@boundaries[i,1])
attrs = c("data-type:value" = as.numeric(gate@boundaries[i,1]))
gatingMLNode$addNode("gating:coordinate", attrs = attrs)
# attrs = c("data-type:value" = gate@boundaries[i,2])
attrs = c("data-type:value" = as.numeric(gate@boundaries[i,2]))
gatingMLNode$addNode("gating:coordinate", attrs = attrs)
gatingMLNode$closeTag() # </gating:vertex>
}
gatingMLNode$closeTag() # </gating:PolygonGate>
}
# Add ellipse gate x to the Gating-ML node
addEllipsoidGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "ellipsoidGate")) stop(paste("Unexpected object insted of an ellipsoidGate - ", class(gate)))
addDebugMessage(paste("Working on ellipsoidGate ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:EllipsoidGate", attrs = attrs, close = FALSE)
addDimensions(gatingMLNode, x, flowEnv)
gatingMLNode$addNode("gating:mean", close = FALSE)
for (i in 1:length(gate@mean))
{
attrs = c("data-type:value" = as.numeric(gate@mean[i]))
gatingMLNode$addNode("gating:coordinate", attrs = attrs)
}
gatingMLNode$closeTag() # </gating:mean>
gatingMLNode$addNode("gating:covarianceMatrix", close = FALSE)
for (row in 1:length(gate@cov[,1]))
{
gatingMLNode$addNode("gating:row", close = FALSE)
for (column in 1:length(gate@cov[1,]))
{
attrs = c("data-type:value" = gate@cov[row,column])
gatingMLNode$addNode("gating:entry", attrs = attrs)
}
gatingMLNode$closeTag() # </gating:row>
}
gatingMLNode$closeTag() # </gating:covarianceMatrix>
attrs = c("data-type:value" = gate@distance ^ 2)
gatingMLNode$addNode("gating:distanceSquare", attrs = attrs)
gatingMLNode$closeTag() # </gating:EllipsoidGate>
}
# Add a Boolean AND gate x to the Gating-ML node
addBooleanAndGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "intersectFilter")) stop(paste("Unexpected object insted of an intersectFilter - ", class(gate)))
addDebugMessage(paste("Working on intersectFilter ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:BooleanGate", attrs = attrs, close = FALSE)
gatingMLNode$addNode("gating:and", close = FALSE)
if(length(gate@filters) == 0)
stop("Boolean AND gates (intersectFilter) have to reference some arguments.", call. = FALSE)
for (i in 1:length(gate@filters))
{
attrs = c("gating:ref" = filterIdtoXMLId(gate@filters[[i]]@filterId, flowEnv))
gatingMLNode$addNode("gating:gateReference", attrs = attrs)
}
if(length(gate@filters) == 1)
{
# If there was just one referenced filter than we add it twice
# since and/or gates require at least two arguments in Gating-ML 2.0
gatingMLNode$addNode("gating:gateReference", attrs = attrs)
}
gatingMLNode$closeTag() # </gating:and>
gatingMLNode$closeTag() # </gating:BooleanGate>
}
# Add a Boolean OR gate x to the Gating-ML node
addBooleanOrGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "unionFilter")) stop(paste("Unexpected object insted of a unionFilter - ", class(gate)))
addDebugMessage(paste("Working on unionFilter ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:BooleanGate", attrs = attrs, close = FALSE)
gatingMLNode$addNode("gating:or", close = FALSE)
if(length(gate@filters) == 0)
stop("Boolean OR gates (unionFilter) have to reference some arguments.", call. = FALSE)
for (i in 1:length(gate@filters))
{
attrs = c("gating:ref" = filterIdtoXMLId(gate@filters[[i]]@filterId, flowEnv))
gatingMLNode$addNode("gating:gateReference", attrs = attrs)
}
if(length(gate@filters) == 1)
{
# If there was just one referenced filter than we add it twice
# since and/or gates require at least two arguments in Gating-ML 2.0
gatingMLNode$addNode("gating:gateReference", attrs = attrs)
}
gatingMLNode$closeTag() # </gating:or>
gatingMLNode$closeTag() # </gating:BooleanGate>
}
# Add a Boolean NOT gate x to the Gating-ML node
addBooleanNotGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "complementFilter")) stop(paste("Unexpected object insted of a complementFilter - ", class(gate)))
addDebugMessage(paste("Working on complementFilter ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:BooleanGate", attrs = attrs, close = FALSE)
gatingMLNode$addNode("gating:not", close = FALSE)
if(length(gate@filters) == 1)
{
attrs = c("gating:ref" = filterIdtoXMLId(gate@filters[[1]]@filterId, flowEnv))
gatingMLNode$addNode("gating:gateReference", attrs = attrs)
} else stop("Boolean NOT gates (complementFilter) have to reference exactly one argument.", call. = FALSE)
gatingMLNode$closeTag() # </gating:not>
gatingMLNode$closeTag() # </gating:BooleanGate>
}
# Add a Quadrant gate x to the Gating-ML node
addQuadGateNode <- function(gatingMLNode, x, flowEnv, addParent, forceGateId)
{
gate = objectNameToObject(x, flowEnv)
if(!is(gate, "quadGate")) stop(paste("Unexpected object insted of a quadGate - ", class(gate)))
addDebugMessage(paste("Working on quadGate ", gate@filterId, sep=""), flowEnv)
myID = getObjectId(gate, forceGateId, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("gating:id" = myID)
if (!is.null(addParent)) attrs = c(attrs, "gating:parent_id" = filterIdtoXMLId(addParent, flowEnv))
gatingMLNode$addNode("gating:QuadrantGate", attrs = attrs, close = FALSE)
addDimensions(gatingMLNode, x, flowEnv, myID)
attrs = c("gating:id" = paste(myID, ".PP", sep = ""))
gatingMLNode$addNode("gating:Quadrant", attrs = attrs, close = FALSE)
attrs = c("gating:divider_ref" = paste(myID, ".D1", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[1] + 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
attrs = c("gating:divider_ref" = paste(myID, ".D2", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[2] + 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
gatingMLNode$closeTag() # </gating:Quadrant>
attrs = c("gating:id" = paste(myID, ".PN", sep = ""))
gatingMLNode$addNode("gating:Quadrant", attrs = attrs, close = FALSE)
attrs = c("gating:divider_ref" = paste(myID, ".D1", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[1] + 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
attrs = c("gating:divider_ref" = paste(myID, ".D2", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[2] - 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
gatingMLNode$closeTag() # </gating:Quadrant>
attrs = c("gating:id" = paste(myID, ".NP", sep = ""))
gatingMLNode$addNode("gating:Quadrant", attrs = attrs, close = FALSE)
attrs = c("gating:divider_ref" = paste(myID, ".D1", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[1] - 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
attrs = c("gating:divider_ref" = paste(myID, ".D2", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[2] + 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
gatingMLNode$closeTag() # </gating:Quadrant>
attrs = c("gating:id" = paste(myID, ".NN", sep = ""))
gatingMLNode$addNode("gating:Quadrant", attrs = attrs, close = FALSE)
attrs = c("gating:divider_ref" = paste(myID, ".D1", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[1] - 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
attrs = c("gating:divider_ref" = paste(myID, ".D2", sep = ""))
attrs = c(attrs, "gating:location" = as.character(gate@boundary[2] - 1))
gatingMLNode$addNode("gating:position", attrs = attrs)
gatingMLNode$closeTag() # </gating:Quadrant>
gatingMLNode$closeTag() # </gating:QuadrantGate>
}
# Add a subsetFilter gate named x to the the Gating-ML node
addGateWithParent <- function(gatingMLNode, x, flowEnv)
{
addDebugMessage(paste("Working on ", x, sep=""), flowEnv)
gate = objectNameToObject(x, flowEnv)
if (!is(gate, "subsetFilter")) stop(paste("Expected a subsetFilter to add a gate with a parent id, but found an object of class", class(gate)))
if (length(gate@filters) == 2){
newX = gate@filters[[1]]
parent = gate@filters[[2]]
if (is(parent, 'filterReference')) parentName = parent@name
else parentName = parent@filterId
addObjectToGatingML(gatingMLNode, newX, flowEnv, parentName, gate@filterId)
}
else stop(paste("Unexpected length of filters for class", class(gate)))
}
# Add a compensation named x to the the Gating-ML node
addCompensation <- function(gatingMLNode, x, flowEnv)
{
myComp = objectNameToObject(x, flowEnv)
if(!is(myComp, "compensation")) stop(paste("Unexpected object insted of a compensation - ", class(myComp)))
addDebugMessage(paste("Working on compensation ", myComp@compensationId, sep=""), flowEnv)
myID = getObjectId(myComp, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
detectors <- colnames(myComp@spillover)
if (is.null(detectors))
{
stop(paste("Cannot export a spillover matrix without column names (", myComp@compensationId, ").", sep=""))
return
}
fluorochromes <- rownames(myComp@spillover)
if(is.null(fluorochromes))
{
if(nrow(myComp@spillover) != ncol(myComp@spillover))
{
stop(paste("Cannot export a non-sqaure spillover (spectrum) matrix without row names (", myComp@compensationId, ").", sep=""))
return
}
else
{
fluorochromes <- detectors
}
}
attrs = c("transforms:id" = myID)
gatingMLNode$addNode("transforms:spectrumMatrix", attrs = attrs, close = FALSE)
gatingMLNode$addNode("transforms:fluorochromes", close = FALSE)
for (fname in fluorochromes)
{
attrs = c("data-type:name" = fname)
gatingMLNode$addNode("data-type:fcs-dimension", attrs = attrs)
}
gatingMLNode$closeTag() # </transforms:fluorochromes>
gatingMLNode$addNode("transforms:detectors", close = FALSE)
for (dname in detectors)
{
attrs = c("data-type:name" = dname)
gatingMLNode$addNode("data-type:fcs-dimension", attrs = attrs)
}
gatingMLNode$closeTag() # </transforms:detectors>
for (rowNo in 1:nrow(myComp@spillover))
{
gatingMLNode$addNode("transforms:spectrum", close = FALSE)
for (colNo in 1:ncol(myComp@spillover))
{
# attrs = c("transforms:value" = myComp@spillover[rowNo,colNo])
attrs = c("transforms:value" = as.vector(myComp@spillover[rowNo,colNo]))
gatingMLNode$addNode("transforms:coefficient", attrs = attrs)
}
gatingMLNode$closeTag() # </transforms:spectrum>
}
gatingMLNode$closeTag() # </transforms:spectrumMatrix>
}
# Add an asinhtGml2 transformation named x to the the Gating-ML node
addAsinhtGml2 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "asinhtGml2")) stop(paste("Unexpected object insted of asinhtGml2 - ", class(myTrans)))
addDebugMessage(paste("Working on asinhtGml2 ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
if (is.finite(myTrans@boundMin)) attrs = append(attrs, c("transforms:boundMin" = myTrans@boundMin))
if (is.finite(myTrans@boundMax)) attrs = append(attrs, c("transforms:boundMax" = myTrans@boundMax))
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:T" = myTrans@T, "transforms:M" = myTrans@M, "transforms:A" = myTrans@A)
gatingMLNode$addNode("transforms:fasinh", attrs = attrs)
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add an asinht transformation named x to the the Gating-ML node.
# Encode asinht from Gating-ML 1.5 compatible parameterization using Gating-ML 2.0
# compatible parameterization as follows:
#
# asinht (ASinH from Gating-ML 1.5) is defined as
# f(x) = asinh(a*x)*b
# asinhtGml2 (fasinh from Gating-ML 2.0) is defined as:
# f(x) = (asinh(x*sinh(M*log(10))/T) + A*log(10)) / ((M+A)*log(10))
# Therefore, we will encode asinht as asinhtGml2 by stating
# A = 0
# M = 1 / (b * log(10))
# T = (sinh(1/b)) / a
# which will give us exactly the right transformation in the Gating-ML 2.0
# compatible parameterization. Btw. log is natural logarithm, i.e., based e
addAsinhtGml1.5 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "asinht")) stop(paste("Unexpected object insted of asinht - ", class(myTrans)))
addDebugMessage(paste("Working on asinht ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
A = 0
M = 1 / (myTrans@b * log(10))
T = (sinh(1/myTrans@b)) / myTrans@a
attrs = c("transforms:T" = T, "transforms:M" = M, "transforms:A" = A)
gatingMLNode$addNode("transforms:fasinh", attrs = attrs)
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a hyperlogtGml2 transformation named x to the the Gating-ML node
addHyperlogtGml2 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "hyperlogtGml2")) stop(paste("Unexpected object insted of hyperlogtGml2 - ", class(myTrans)))
addDebugMessage(paste("Working on hyperlogtGml2 ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
if (is.finite(myTrans@boundMin)) attrs = append(attrs, c("transforms:boundMin" = myTrans@boundMin))
if (is.finite(myTrans@boundMax)) attrs = append(attrs, c("transforms:boundMax" = myTrans@boundMax))
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:T" = myTrans@T, "transforms:M" = myTrans@M, "transforms:W" = myTrans@W, "transforms:A" = myTrans@A)
gatingMLNode$addNode("transforms:hyperlog", attrs = attrs)
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a logicletGml2 transformation named x to the the Gating-ML node
addLogicletGml2 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "logicletGml2")) stop(paste("Unexpected object insted of logicletGml2 - ", class(myTrans)))
addDebugMessage(paste("Working on logicletGml2 ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
if (is.finite(myTrans@boundMin)) attrs = append(attrs, c("transforms:boundMin" = myTrans@boundMin))
if (is.finite(myTrans@boundMax)) attrs = append(attrs, c("transforms:boundMax" = myTrans@boundMax))
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:T" = myTrans@T, "transforms:M" = myTrans@M, "transforms:W" = myTrans@W, "transforms:A" = myTrans@A)
gatingMLNode$addNode("transforms:logicle", attrs = attrs)
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a lintGml2 transformation named x to the the Gating-ML node
addLintGml2 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "lintGml2")) stop(paste("Unexpected object insted of lintGml2 - ", class(myTrans)))
addDebugMessage(paste("Working on lintGml2 ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
if (is.finite(myTrans@boundMin)) attrs = append(attrs, c("transforms:boundMin" = myTrans@boundMin))
if (is.finite(myTrans@boundMax)) attrs = append(attrs, c("transforms:boundMax" = myTrans@boundMax))
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:T" = myTrans@T, "transforms:A" = myTrans@A)
gatingMLNode$addNode("transforms:flin", attrs = attrs)
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a logtGml2 transformation named x to the the Gating-ML node
addLogtGml2 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "logtGml2")) stop(paste("Unexpected object insted of logtGml2 - ", class(myTrans)))
addDebugMessage(paste("Working on logtGml2 ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
if (is.finite(myTrans@boundMin)) attrs = append(attrs, c("transforms:boundMin" = myTrans@boundMin))
if (is.finite(myTrans@boundMax)) attrs = append(attrs, c("transforms:boundMax" = myTrans@boundMax))
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:T" = myTrans@T, "transforms:M" = myTrans@M)
gatingMLNode$addNode("transforms:flog", attrs = attrs)
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a ratiotGml2 transformation named x to the the Gating-ML node
addRatiotGml2 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "ratiotGml2")) stop(paste("Unexpected object insted of ratiotGml2 - ", class(myTrans)))
addDebugMessage(paste("Working on ratiotGml2 ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
if (is.finite(myTrans@boundMin)) attrs = append(attrs, c("transforms:boundMin" = myTrans@boundMin))
if (is.finite(myTrans@boundMax)) attrs = append(attrs, c("transforms:boundMax" = myTrans@boundMax))
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:A" = myTrans@pA, "transforms:B" = myTrans@pB, "transforms:C" = myTrans@pC)
gatingMLNode$addNode("transforms:fratio", attrs = attrs, close = FALSE)
addDimensionContents(gatingMLNode, myTrans@numerator, flowEnv)
addDimensionContents(gatingMLNode, myTrans@denominator, flowEnv)
gatingMLNode$closeTag() # </transforms:fratio>
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a ratio transformation (from Gating-ML 1.5) named x
# to the the Gating-ML node. This will be translated to how "fratio" of Gating-ML 2.0
# (When we set A = 1, B = 0, C = 0 then ratio of Gating-ML 1.5 == fratio of Gating-ML 2.0)
addRatioGml1.5 <- function(gatingMLNode, x, flowEnv)
{
myTrans = objectNameToObject(x, flowEnv)
if(!is(myTrans, "ratio")) stop(paste("Unexpected object insted of ratio - ", class(myTrans)))
addDebugMessage(paste("Working on ratio ", myTrans@transformationId, sep=""), flowEnv)
myID = getObjectId(myTrans, NULL, flowEnv)
if(isIdWrittenToXMLAlready(myID, flowEnv)) return(FALSE)
attrs = c("transforms:id" = myID)
gatingMLNode$addNode("transforms:transformation", attrs = attrs, close = FALSE)
attrs = c("transforms:A" = "1", "transforms:B" = "0", "transforms:C" = "0")
gatingMLNode$addNode("transforms:fratio", attrs = attrs, close = FALSE)
addDimensionContents(gatingMLNode, myTrans@numerator, flowEnv)
addDimensionContents(gatingMLNode, myTrans@denominator, flowEnv)
gatingMLNode$closeTag() # </transforms:fratio>
gatingMLNode$closeTag() # </transforms:transformation>
}
# Add a Gating-ML dimension to a Gating-ML node
addDimensions <- function(gatingMLNode, x, flowEnv, quadGateDividerIdBasedName = NULL)
{
gate = objectNameToObject(x, flowEnv)
for (i in 1:length(gate@parameters))
{
attrs = c()
parameter = gate@parameters[[i]]
if (is(gate, "rectangleGate"))
{
min = gate@min[[i]]
max = gate@max[[i]]
if(min != -Inf) attrs = c(attrs, "gating:min" = min)
if(max != Inf) attrs = c(attrs, "gating:max" = max)
}
if(is(parameter, "transformReference")) parameter = resolveTransformationReference(parameter)
if(is(parameter, "unitytransform")) attrs = c(attrs, "gating:compensation-ref" = "uncompensated")
else if(is(parameter, "singleParameterTransform"))
{
attrs = c(attrs, "gating:transformation-ref" = filterIdtoXMLId(parameter@transformationId, flowEnv))
parameter = parameter@parameters
if(is(parameter, "transformReference")) parameter = resolveTransformationReference(parameter)
if(is(parameter, "unitytransform")) attrs = c(attrs, "gating:compensation-ref" = "uncompensated")
else if(is(parameter, "compensatedParameter")) attrs = addCompensationRef(attrs, parameter, flowEnv)
else if(is(parameter, "ratiotGml2") || is(parameter, "ratio")) attrs = addCompensationRef(attrs, parameter@numerator, flowEnv)
else stop(paste("Unexpected parameter class ", class(parameter), ", compound transformations are not supported in Gating-ML 2.0.", sep=""))
}
else if(is(parameter, "compensatedParameter")) attrs = addCompensationRef(attrs, parameter, flowEnv)
else if(is(parameter, "ratiotGml2") || is(parameter, "ratio")) attrs = addCompensationRef(attrs, parameter@numerator, flowEnv)
else stop(paste("Unexpected parameter class", class(parameter), "- not supported in Gating-ML 2.0 output)."))
if(is(gate, "quadGate"))
{
attrs = c(attrs, "gating:id" = paste(quadGateDividerIdBasedName, ".D", i, sep = ""))
gatingMLNode$addNode("gating:divider", attrs = attrs, close = FALSE)
}
else gatingMLNode$addNode("gating:dimension", attrs = attrs, close = FALSE)
addDimensionContents(gatingMLNode, parameter, flowEnv)
if (is(gate, "quadGate")) gatingMLNode$addNode("gating:value", as.character(gate@boundary[i]))
gatingMLNode$closeTag() # </gating:dimension> or </gating:divider>
}
}
# Add the contents of a Gating-ML dimension to a Gating-ML node
addDimensionContents <- function(gatingMLNode, parameter, flowEnv)
{
newDimension = FALSE
if(is(parameter, "compensatedParameter"))
{
if (parameter@spillRefId == "SpillFromFCS")
attrs = c("data-type:name" = parameter@parameters)
else
attrs = c("data-type:name" = parameter@transformationId)
}
else if(is(parameter, "unitytransform")) attrs = c("data-type:name" = parameter@parameters)
else if(is(parameter, "character")) attrs = c("data-type:name" = parameter)
else if(is(parameter, "ratiotGml2") || is(parameter, "ratio")) {
attrs = c("data-type:transformation-ref" = parameter@transformationId)
newDimension = TRUE
}
else stop(paste("Unrecognized parameter type, class ", class(parameter), ". Note that compound transformations are not supported in Gating-ML 2.0.", sep=""))
if(newDimension)
gatingMLNode$addNode("data-type:new-dimension", attrs = attrs)
else
gatingMLNode$addNode("data-type:fcs-dimension", attrs = attrs)
}
# This converts the identifier to an XML safe identifier and also,
# if it is a singleParameterTransform and we have a different
# 'representative' transform for those (saved in flowEnv[['.singleParTransforms']])
# then the identifier of the representative is used instead.
filterIdtoXMLId <- function(x, flowEnv)
{
if(!(is.character(x))) stop(paste("Object of class", class(x), "cannot be converted to an XML identifier."))
if(length(x) <= 0) stop(paste("An empty string cannot be converted to an XML identifier."))
# First, if it is a singleParameterTransform then check for a representative and use it instead eventually
trEnv = flowEnv[['.singleParTransforms']]
trans = flowEnv[[x]]
if(!is.null(trEnv) && !is.null(trans) && is(trans, "singleParameterTransform"))
{
key = createTransformIdentifier(trans)
if (!is.null(trEnv[[key]])) x = trEnv[[key]]
}
# Now make it a safe XML identifier
# 1) Put an underscore prefix if it starts with a number
if(substr(x, 1, 1) >= "0" && substr(x, 1, 1) <= "9") x = paste("_", x, sep="")
# 2) Replace 'strange characters with '.'
for(i in 1:nchar(x)) {
if(!isNCNameChar(substr(x, i, i))) x <- paste(substr(x, 0, i - 1), '.', substr(x, i + 1, nchar(x)), sep= "")
}
x
}
# Return true if you are sure that the character is safe to be placed in
# an XML identifier.
isNCNameChar <- function(char)
{
# Based on the ASCII table and XML NCName syntax
asciiValue = as.numeric(charToRaw(char))
if(asciiValue < 45) return(FALSE)
if(asciiValue == 47) return(FALSE)
if(asciiValue >= 58 && asciiValue <= 64) return(FALSE)
if(asciiValue >= 91 && asciiValue <= 94) return(FALSE)
if(asciiValue == 96) return(FALSE)
if(asciiValue >= 123) return(FALSE)
TRUE
}
# Returns TRUE if and only if x is a singleParameterTransform
# and there is another equivalent singleParameterTransform
# in flowEnv that is the chosen representative among all
# equivalent transforms. This is used to merge transforms
# for Gating-ML 2.0 output since in Gating-ML 2.0, the same
# transformation is applicable to many FCS parameters. For us,
# the transformation with the shortest identifier is the chosen
# representative. This function requires the flowEnv[['.singleParTransforms']]
# to be set by calling the collectTransform function on all available
# transforms before shouldTransformationBeSkipped can be used.
shouldTransformationBeSkipped <- function(x, flowEnv)
{
trEnv = flowEnv[['.singleParTransforms']]
trans = flowEnv[[x]]
if(!is.null(trEnv) && !is.null(trans) && is(trans, "singleParameterTransform"))
{
key = createTransformIdentifier(trans)
if (!is.null(trEnv[[key]])){
if (x == trEnv[[key]]) FALSE
else TRUE
} else FALSE
} else FALSE
}
# Resolve transformation reference, return the transformation that the
# reference is pointing to.
resolveTransformationReference <- function(trRef)
{
if(!is(trRef, "transformReference"))
stop(paste("Cannot call resolveTransformationReference on", class(trRef)))
if(exists(trRef@transformationId, envir=trRef@searchEnv, inherits=FALSE))
trRef@searchEnv[[trRef@transformationId]]
else
stop(paste("Cannot find", trRef@transformationId, "in the environment."))
}
# This will create an identifier of a singleParameterTransform that
# is based on the class and slot values, such as T, M, W, A, etc. as applicable
# for the various single parameter transformations. We will use this to
# merge "the same transformations" applied to different FCS parameter into a single
# transformation in the Gating-ML 2.0 output.
createTransformIdentifier <- function(trans)
{
name <- class(trans)
for (slotName in slotNames(trans))
{
if(slotName != ".Data" && slotName != "parameters" && slotName != "transformationId")
{
slotValue = slot(trans, slotName)
if(is(slotValue, "numeric") || is(slotValue, "character"))
{
name <- paste(name, slotName, slot(trans, slotName), sep = "_")
}
}
}
name
}
# The flowEnv[['.singleParTransforms']] environment will serve as a hashmap
# with keys based on values returned by createTransformIdentifier and
# values being the shortest transformationId value of all the transformations
# matching that key. That way, we can merge all these transformations into
# a single one in Gating-ML.
collectTransform <- function(x, flowEnv)
{
trEnv = flowEnv[['.singleParTransforms']]
trans = flowEnv[[x]]
key = createTransformIdentifier(trans)
if (is.null(trEnv[[key]]) || length(trEnv[[key]]) > trans@transformationId) trEnv[[key]] = trans@transformationId
}
# Add a debug message to out list of debug messages in flowEnv[['.debugMessages']]
addDebugMessage <- function(msg, flowEnv)
{
flowEnv[['.debugMessages']] = c(flowEnv[['.debugMessages']], msg)
}
# Return TRUE of the provided id has been checked (and supposedly written)
# before. Otherwise, add the id to the list in flowEnv[['.objectIDsWrittenToXMLOutput']]
# and retusn FALSE. This function is used to prevent writing multiple objects
# with the same ID to the Gating-ML output in case a gate or transformation
# with the same ID is stored several times in the flowEnv.
isIdWrittenToXMLAlready <- function(id, flowEnv)
{
idsList = flowEnv[['.objectIDsWrittenToXMLOutput']]
if (is.null(idsList[[id]])) {
idsList[[id]] = TRUE
flowEnv[['.objectIDsWrittenToXMLOutput']] = idsList
FALSE
} else {
addDebugMessage(paste("ID", id, "should be in the Gating-ML file already."), flowEnv)
TRUE
}
}
# Add an appropriate gating:compensation-ref attribute to the passed attrs
addCompensationRef <- function(attrs, parameter, flowEnv)
{
if(is(parameter, "unitytransform")) attrs = c(attrs, "gating:compensation-ref" = "uncompensated")
else if(is(parameter, "compensatedParameter"))
{
if (parameter@spillRefId != "SpillFromFCS")
attrs = c(attrs, "gating:compensation-ref" = filterIdtoXMLId(parameter@spillRefId, flowEnv))
else
attrs = c(attrs, "gating:compensation-ref" = "FCS")
}
else stop(paste("Unexpected parameter class", class(parameter)))
attrs
}
# Add to attrs the gating:min and/or gating:max attributes
# based on dimension number i of a rectangle gate gate.
addRectGateMinMax <- function(attrs, gate, i)
{
if (is(gate, "rectangleGate"))
{
min = gate@min[[i]]
max = gate@max[[i]]
if(min != -Inf) attrs = c(attrs, "gating:min" = min)
if(max != Inf) attrs = c(attrs, "gating:max" = max)
} else stop(paste("Unexpected gate class", class(gate), "- expected a rectangleGate."))
attrs
}
# Get the XML compliant identifier of an object. This only works for object of type
# "filter", "transform" or "compensation". The filterIdtoXMLId function is incorporated,
# which includes the use of representative singleParameterTransforms instead of a different
# transform whenever it is applied to a different FCS parameter.
getObjectId <- function(object, forceGateId, flowEnv)
{
if (is(object, "filter")) {
if (is.null(forceGateId)) myID = filterIdtoXMLId(object@filterId, flowEnv)
else myID = filterIdtoXMLId(forceGateId, flowEnv)
} else if (is(object, "transform")) {
if (is.null(forceGateId)) myID = filterIdtoXMLId(object@transformationId, flowEnv)
else myID = filterIdtoXMLId(forceGateId, flowEnv)
} else if (is(object, "compensation")) {
if (is.null(forceGateId)) myID = filterIdtoXMLId(object@compensationId, flowEnv)
else myID = filterIdtoXMLId(forceGateId, flowEnv)
}
else stop(paste("Unexpected object to get id from, class", class(object)))
myID
}
# If x is character then return flowEnv[[x]], otherwise return x
objectNameToObject <- function(x, flowEnv)
{
if(is(x, "character")) flowEnv[[x]]
else x
}
# Check object named x in flowEnv and make sure
# flowEnv contains objects referenced from x, such as parameter
# transformations used in x. If objects are missing then
# add them to flowEnv and keep track of what has been
# added in the flowEnv[['.addedObjects']] list so that it can be
# removed at the end of the write.gatingML function.
addReferencedObjectsToEnv <- function(x, flowEnv)
{
object = objectNameToObject(x, flowEnv)
if(is(object, "parameterFilter"))
for(par in object@parameters) doubleCheckExistanceOfParameter(par, flowEnv)
else if (is(object, "singleParameterTransform"))
doubleCheckExistanceOfParameter(object@parameters, flowEnv)
else if (is(object, "setOperationFilter"))
for(filt in object@filters) doubleCheckExistanceOfFilter(filt, flowEnv)
}
# If par is a transform then check whether it exists in the flowEnv environment,
# and if it doesn't then add it there and make a note of it in flowEnv[['.addedObjects']]
doubleCheckExistanceOfParameter <- function(par, flowEnv)
{
if(is(par, "transform"))
{
if(!is.null(par@transformationId) && par@transformationId != "" && !exists(par@transformationId, envir=flowEnv, inherits=FALSE))
{
flowEnv[[par@transformationId]] <- par
flowEnv[['.addedObjects']][[par@transformationId]] <- par@transformationId
addReferencedObjectsToEnv(par@transformationId, flowEnv)
}
}
}
# If filt is a concreteFilter then check whether it exists in the flowEnv environment,
# and if it doesn't then add it there and make a note of it in flowEnv[['.addedObjects']]
doubleCheckExistanceOfFilter <- function(filt, flowEnv)
{
if(is(filt, "concreteFilter"))
{
if(!is.null(filt@filterId) && filt@filterId != "" && !exists(filt@filterId, envir=flowEnv, inherits=FALSE))
{
flowEnv[[filt@filterId]] <- filt
flowEnv[['.addedObjects']][[filt@filterId]] <- filt@filterId
addReferencedObjectsToEnv(filt@filterId, flowEnv)
}
}
}
