R/createXGMML.R

In rsilvabioinfo/ProbMetab: Probabilistic annotation of LC-MS based metabolomics

#' createXGMML
#'
#' Creates a Cytoscape xgmml readable file.  
#' 
#' @param gr a graphNEL object generated by edge matrices provided by reac2cor. 
#' @param node.label a character vector containing the name of each node. 
#' @param cwName Cytoscape window name. 
#' @param node.form data.frame containing the names of the nodes in the first 
#' column, and TRUE/FALSE vectors for graph parameters in the additional
#' columns. The column name should have the parameter type, color and shape
#' and the value in the format "color.#FF0000".
#' @param edge.form data.frame containing the names of the nodes in the first 
#' column, and TRUE/FALSE vectors for graph parameters in the additional
#' columns. The column name should have the parameter type, color, width and style, 
#' and the value in the format "color.#FF0000".
#' @param attributes classification table created by export.class.table function.    
#' @param path system path to save the file. 
#' @return Cytoscape xgmml readable file. 
#'
#' @export
 
createXGMML <- function(gr, node.label, cwName="test", node.form=NULL, edge.form=NULL, attributes=NULL, path){
  ##node.form & edge.form -> used when the user wants to set atributes to nodes/edges (e.g. color, etc). *is it right ?
  
  ## dependencies
#  require(RCytoscape)
#  require(XML)
  
  i <- 1; system.time(lapply(gr@edgeL, function(x) { if(length(x$edges)) { gr@edgeL[[i]]$edges <<- x$edges[x$edges>i] }; i <<- i+1 }) )  
  
  ## aux. functions (!-cwName, mass.data, edgeData, savingPath)
  createXGMMLFile <- function( gr, node.label, cwName="test", node.form=NULL, edge.form=NULL, path)  {
    #if("XML" %in% rownames(installed.packages()) == FALSE) {install.packages("xtable")} else{library("XML")}
    
    ##top (and top-att) is fixed - xgmml header - I'll fix it, make it in a better shape (maybe creating and configurable input for the user - sounds smart, doesn't it ?)
    top = newXMLNode("graph", attrs=c(label=cwName, directed="1"), namespaceDefinitions=c( dc="http://purl.org/dc/elements/1.1/", xlink="http://www.w3.org/1999/xlink", rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#", cy="http://www.cytoscape.org", "http://www.cs.rpi.edu/XGMML"))
    attr1 = newXMLNode("att", attrs=c(type="real", name="backgroundColor", value="#ccccff"))  
    attr2 = newXMLNode("att", attrs=c(type="real", name="GRAPH_VIEW_ZOOM", value="0.6847603167087344") ) 
    attr3 = newXMLNode("att", attrs=c(type="real", name="GRAPH_VIEW_CENTER_X", value="1216.235294117646") ) 
    attr4 = newXMLNode("att", attrs=c(type="real", name="GRAPH_VIEW_CENTER_Y", value="1216.235294117646") ) 
    attr5 = newXMLNode("att", attrs=c(type="real", name="NODE_SIZE_LOCKED", value="true") )
    attr6 = newXMLNode("att", attrs=c(type="string", name="__layoutAlgorithm", value="grid", 'cy:hidden'="true"), suppressNamespaceWarning=TRUE)
    addChildren(top, list(attr1, attr2, attr3, attr4, attr5, attr6))
    ## end-top
    
    if(!is.null(attributes)){ # Prepare my attributes var 
      
      filterMSELTab <- function(msel){
        msel = cbind(msel, row=rownames(msel));r = NULL
        for(i in unique(msel[, "Id"])){
          if(length(which(msel[, "Id"] == i)) > 1 ){
            r = rbind(r, msel[as.numeric(msel[which(msel[, "Id"] == i),][which.max(as.numeric(msel[which(msel[, "Id"] == i),][, "Probability"])),"row"]),])
          }
          else{
            r = rbind(r, msel[which(msel[, "Id"] == i),])
          }
        }
        r = r[,-8]
        return(r)
      }
      
      
      
      attributes = filterMSELTab(attributes)
    
    
    }# end-if null attributes
    
    
    ## aux
    
    setAttById = function(attributes, id){
      if(is.null(attributes)) {return(NULL)}
      l = list(NULL)
      attributes = attributes[which(attributes[,"Id"] == id),]
      for(i in 1:length(names(attributes))){
        l[[i]] = newXMLNode("att", attrs=c(  type="string", name=names(attributes)[i], value=as.character(attributes[i])   ))
      }
      return(l)
    }
    
    
    ## node
    if(!is.null(node.form)){
      
      editNodeColor <- function(x){
        if(x == " TRUE") return("#FF0000")
        else return("#0000FF")
      }
      editNodeShape <- function(x){
        if(x == " TRUE") return("TRIANGLE")
        else return("ELLIPSE")
      }
      node = apply(node.form, 1, function(x) {newXMLNode("node", attrs=c(label=x[1], id=x[1]), setAttById(attributes, x[1]), parent=top )}   )
      if(!is.null(node.label)){
        i<- 1; att = lapply(node.label, function(x) { i <<- i+1; newXMLNode("att", attrs=c(type="string", name="node.label", value=x) , parent=node[[i-1]])} )
      }
      i<- 1; graphics = apply(node.form, 1, function(x) { i <<- i+1; newXMLNode("graphics", attrs=c( type=editNodeShape(x[3]), fill=editNodeColor(x[2]), h="40.0", w="40.0", x="1331.0", y="2790.0", width="1", outline="#666666", "cy:nodeTransparency"="1.0", 'cy:nodeLabelFont'="SansSerif.bold-0-12", 'cy:nodeLabel'=as.character(xmlAttrs(node[[i-1]])[2]), 'cy:borderLineType'="solid") , parent=node[[i-1]], suppressNamespaceWarning=TRUE)} )
      addChildren(top, node)
    }
    else{
    node = lapply(nodes(gr), function(x) {newXMLNode("node", attrs=c(label=x, id=x), setAttById(attributes, x[1]),parent=top )}   )
    if(!is.null(node.label)){
      i<- 1; att = lapply(node.label, function(x) { i <<- i+1; newXMLNode("att", attrs=c(type="string", name="node.label", value=x) , parent=node[[i-1]])} )
    }
    i<- 1; graphics = lapply(nodes(gr), function(x) { i <<- i+1; newXMLNode("graphics", attrs=c(type="ELLIPSE", h="40.0", w="40.0", x="1331.0", y="2790.0", fill="#FF0000", width="1", outline="#666666", "cy:nodeTransparency"="1.0", 'cy:nodeLabelFont'="SansSerif.bold-0-12", 'cy:nodeLabel'=as.character(xmlAttrs(node[[i-1]])[2]), 'cy:borderLineType'="solid") , parent=node[[i-1]])} )
    addChildren(top, node)
    }#end-else node
    
    
    ## edge
    if(!is.null(edge.form)){
      coln = colnames(edge.form)
      
      editEdgeNameColor <- function(x){
        if(x == " TRUE") return("#FF0000")
        else return("#0000FF")
      }
      editEdgeNameWidth <- function(x){
        if(x == " TRUE") return("5")
        else return("1")
      }
      
#       edit <- function(type, logic, value){
#         if(logic == " TRUE") return(paste("'", type, "'","=","'",value,"'", sep=""))
#         else return(NULL)
#       }
#       
#       edit <- function(type, logic, value){
#         if(logic == " TRUE") return(paste(type,"=",value, sep=""))
#         else return(NULL)
#       }
      if(length(coln) == 3){
        edge = apply(edge.form,1, function(x)  newXMLNode("edge", attrs=c(label=paste(strsplit(as.character.default(x[1]), "~")[[1]][1],"(undefined)", strsplit(as.character.default(x[1]), "~")[[1]][2]), source=strsplit(as.character.default(x[1]), "~")[[1]][1], target=strsplit(as.character.default(x[1]), "~")[[1]][2]) ) )
        i<- 1; graphics = apply(edge.form, 1, function(x) { i <<- i+1; newXMLNode("graphics", attrs=c( fill=editEdgeNameColor(x[2]), width=editEdgeNameWidth(x[3]), 'cy:sourceArrow'="0", 'cy:targetArrow'="0", 'cy:sourceArrowColor'="#000000", 'cy:targetArrowColor'="#000000", 'cy:edgeLabelFont'="Default-0-10", 'cy:edgeLabel'="" , 'cy:edgeLineType'="SOLID" , 'cy:curved'="STRAIGHT_LINES"), parent=edge[[i-1]], suppressNamespaceWarning=TRUE)} )
        addChildren(top, edge)
      }
      if(length(coln) == 2){
        edge = apply(edge.form,1, function(x)  newXMLNode("edge", attrs=c(label=paste(strsplit(as.character.default(x[1]), "~")[[1]][1],"(undefined)", strsplit(as.character.default(x[1]), "~")[[1]][2]), source=strsplit(as.character.default(x[1]), "~")[[1]][1], target=strsplit(as.character.default(x[1]), "~")[[1]][2]) ) )
        i<- 1; graphics = apply(edge.form, 1, function(x) { i <<- i+1; newXMLNode("graphics", attrs=c( fill=editEdgeNameColor(x[2]), width="1", 'cy:sourceArrow'="0", 'cy:targetArrow'="0", 'cy:sourceArrowColor'="#000000", 'cy:targetArrowColor'="#000000", 'cy:edgeLabelFont'="Default-0-10", 'cy:edgeLabel'="" , 'cy:edgeLineType'="SOLID" , 'cy:curved'="STRAIGHT_LINES"), parent=edge[[i-1]], suppressNamespaceWarning=TRUE)} )
        addChildren(top, edge)
      }
    }else{ ##no edge.form
      edge = lapply(edgeNames(gr), function(x)  newXMLNode("edge", attrs=c(label=strsplit(as.character.default(x), "~")[[1]][2], source=strsplit(as.character.default(x), "~")[[1]][1], target=strsplit(as.character.default(x), "~")[[1]][2]) ) )
      i<- 1; graphics = lapply(edgeNames(gr), function(x) { i <<- i+1; newXMLNode("graphics", attrs=c( width="1", fill="#000000", 'cy:sourceArrow'="0", 'cy:targetArrow'="0", 'cy:sourceArrowColor'="#000000", 'cy:targetArrowColor'="#000000", 'cy:edgeLabelFont'="Default-0-10", 'cy:edgeLabel'="" , 'cy:edgeLineType'="SOLID" , 'cy:curved'="STRAIGHT_LINES"), parent=edge[[i-1]], suppressNamespaceWarning=TRUE)} )
      addChildren(top, edge)
    }
    saveXML(top, path)    
  } # end-of createXGMMLFile
  createXGMMLFile(gr, node.label, cwName, node.form, edge.form, path)
}