File: GXLformals.R

package info (click to toggle)
r-bioc-graph 1.60.0-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 2,076 kB
  • sloc: ansic: 842; makefile: 12; sh: 3
file content (141 lines) | stat: -rw-r--r-- 4,615 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
#
# GXL support
#

## fromGXL returns the graphNEL object only, and it may
##  need to return more properties (7 mar 03)

setMethod("fromGXL", signature(con="connection"),
          function(con) {
              contents <- paste(readLines(con), collapse="")
              xmlEventParse <- getExportedValue("XML", "xmlEventParse")
              xmlEventParse(contents, graph_handler(),
                            asText=TRUE,
                            saxVersion=2)$asGraphNEL()
          })


## dumpGXL returns an R list with all? properties

     setMethod("dumpGXL", "connection", function(con)
       {
       xmlEventParse <- getExportedValue("XML", "xmlEventParse")
       xmlEventParse(paste(readLines(con), collapse=""),
                     NELhandler(),asText=TRUE)$dump()
       })
## validate against the dtd

     setMethod("validateGXL", "connection", function(con)
       {
       xmlTreeParse <- getExportedValue("XML", "xmlTreeParse")
# maybe need a try here, xmlTreeParse dumps the whole stream when it hits an error
       tmp <- xmlTreeParse(paste(readLines(con), collapse=""),
              asText=TRUE, validate=TRUE)
       })
#
#  exporting
#

    setMethod("toGXL", signature(object="graphNEL"),
              function(object, graph.name) {
                  if (missing(graph.name)) {
                      graph.name <- class(object)[1]
                  }
                  gxlTreeNEL(object, graph.name)
              })


gxlTreeNEL <- function(gnel, graph.name) {
    qrequire("XML")
    GXL_NAMESPACE <- c(gxl="http://www.gupro.de/GXL/gxl-1.1.dtd")
    out <- XML::xmlOutputDOM("gxl", nsURI=GXL_NAMESPACE, nameSpace="gxl")
    ## NOTE: We could specify dtd="http://www.gupro.de/GXL/gxl-1.0.1.dtd",
    ##       but this might mean that net access is required to write
    ##       GXL which seems quite unacceptable.
    nodeAttrs <- names(nodeDataDefaults(gnel))
    edgeAttrs <- names(edgeDataDefaults(gnel))

    writeAttr <- function(attrName, val) {
        ## skip NA and NULL
        if (is.null(val) || is.na(val))
          return(NULL)
        ## at present, can only handle length 1
        if (length(val) > 1) {
            warning("GXL conversion only handles attributes ",
                    "with length 1.  Will try to represent ",
                    "object of length ", length(val), " as a",
                    "string.")
            val <- paste(val, collapse=", ")
        }
        atag <- switch(typeof(val),
                       integer="int",
                       character="string",
                       double="float",
                       {
                           warning("I don't know how to convert ",
                                   "a ", typeof(val), " to GXL. ",
                                   " Skipping.")
                           NULL
                       })
        if (is.null(atag))
          return(NULL)
        out$addTag("attr", attrs=c(name=attrName), close=FALSE)
        out$addTag(atag, as.character(val))
        out$closeTag()
    }
    
    writeNode <- function(n) {
        ## Helper function to write a graphNEL node to XML
        out$addTag("node", attrs=c(id=n), close=FALSE)
        for (nodeAttr in nodeAttrs) {
            val <- nodeData(gnel, n, attr=nodeAttr)[[1]]
            writeAttr(nodeAttr, val)
        }
        out$closeTag() ## node
    }

    edgeCount <- 1
    writeEdge <- function(from, to) {
        ## Helper function to write a graphNEL node to XML
        edgeId <- edgeCount
        edgeCount <<- edgeCount + 1
        out$addTag("edge", attrs=c(id=edgeId, from=from, to=to),
                   close=FALSE)
        for (edgeAttr in edgeAttrs) {
            val <- edgeData(gnel, from, to, attr=edgeAttr)[[1]]
            writeAttr(edgeAttr, val)
        }
        out$closeTag() ## node
    }
    
    nds <- nodes(gnel)
    if (!isDirected(gnel)) {
        ## remove recipricol edges
        eds <- lapply(gnel@edgeL, function(x) x$edges)
        eds <- mapply(function(x, y) x[x < y], eds, seq(length=length(eds)))
        names(eds) <- nodes(gnel)
        eds <- lapply(eds, function(x) {
            if (length(x) > 0)
              nds[x]
            else
              character(0)
        })
    } else {
        eds <- edges(gnel)
    }
    enms <- names(eds)
    out$addTag("graph", attrs=c(id=graph.name, edgemode=edgemode(gnel)),
               close=FALSE)
    for (n in nds) {
        writeNode(n)
    }
    for (from in enms) {
        for (to in eds[[from]]) {
            writeEdge(from=from, to=to)
        }
    }
    out$closeTag() # graph
    out
}