R/writeGatingML.R

In flowUtils: Utilities for flow cytometry

#############################################
## 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/flowUtils/flowCore")
    gatingMLNode$addNode("R-version", sessionInfo()$R.version$version.string)
    gatingMLNode$addNode("flowCore-version", as.character(packageVersion("flowCore")))
    gatingMLNode$addNode("flowUtils-version", as.character(packageVersion("flowUtils")))
    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)
        }    
    }
}