# SCM Repository

[matrix] Diff of /pkg/R/sparseMatrix.R
 [matrix] / pkg / R / sparseMatrix.R

# Diff of /pkg/R/sparseMatrix.R

revision 1270, Thu May 18 06:44:43 2006 UTC revision 1271, Thu May 18 06:47:09 2006 UTC
# Line 16  Line 16
16  ##  -----               *not* required on purpose  ##  -----               *not* required on purpose
17  ## Note: 'undirected' graph <==> 'symmetric' matrix  ## Note: 'undirected' graph <==> 'symmetric' matrix
18
19  setAs("graphNEL", "sparseMatrix",  ## Add some utils that may no longer be needed in future versions of the 'graph' package
20    graph.has.weights <- function(g) "weight" %in% names(edgeDataDefaults(g))
21
22    graph.wgtMatrix <- function(g)
23    {
24        ## Purpose: work around "graph" package's  as(g, "matrix") bug
25        ## ----------------------------------------------------------------------
26        ## Arguments: g: an object inheriting from (S4) class "graph"
27        ## ----------------------------------------------------------------------
28        ## Author: Martin Maechler, based on Seth Falcon's code;  Date: 12 May 2006
29
30        ## MM: another buglet for the case of  "no edges":
31        if(numEdges(g) == 0) {
32          p <- length(nd <- nodes(g))
33          return( matrix(0, p,p, dimnames = list(nd, nd)) )
34        }
35        ## Usual case, when there are edges:
36        has.w <- "weight" %in% names(edgeDataDefaults(g))
37        if(has.w) {
38            w <- unlist(edgeData(g, attr = "weight"))
39            has.w <- any(w != 1)
40        } ## now 'has.w' is TRUE  iff  there are weights != 1
41        m <- as(g, "matrix")
42        ## now is a 0/1 - matrix (instead of 0/wgts) with the 'graph' bug
43        if(has.w) { ## fix it if needed
44            tm <- t(m)
45            tm[tm != 0] <- w
46            t(tm)
47        }
48        else m
49    }
50
51
52    setAs("graphAM", "sparseMatrix",
53        function(from) {        function(from) {
54            .Call("graphNEL_as_dgTMatrix",            symm <- edgemode(from) == "undirected" && isSymmetric(from@adjMat)
55                  from,            ## This is only ok if there are no weights...
56                  symmetric = (from@edgemode == "undirected"),            if(graph.has.weights(from)) {
57                  PACKAGE = "Matrix")                as(graph.wgtMatrix(from),
58                     if(symm) "dsTMatrix" else "dgTMatrix")
59              }
60              else { ## no weights: 0/1 matrix -> logical
61                  as(as(from, "matrix"),
62                     if(symm) "lsTMatrix" else "lgTMatrix")
63              }
64        })        })
65
66    ## FIXME: in the case of NEL or other sparse graphs, we really should *NOT* go
67    ##        via a *dense* adjacency matrix as we do here :
68    setAs("graph", "sparseMatrix",
69          function(from) as(as(from, "graphAM"), "sparseMatrix"))
70    ## but rather
71    if(FALSE) { #------------------------- NOT YET -----------------
72  setAs("graph", "sparseMatrix",  setAs("graph", "sparseMatrix",
73        function(from) as(as(from,"graphNEL"), "sparseMatrix"))        function(from) as(as(from,"graphNEL"), "sparseMatrix"))
74
75  ##! if(FALSE) {##--- not yet  setAs("graphNEL", "sparseMatrix",
76          function(from) {
77              nd <- nodes(from)
78              symm <- edgemode(from) == "undirected"
79              if(graph.has.weights(from)) {
80                  ## symm <- symm && <weights must also be symmetric>: improbable
81                  ## if(symm) new("dsTMatrix", .....) else
82                  new("dgTMatrix", .....)
83              }
84              else { ## no weights: 0/1 matrix -> logical
85                  if(symm) new("lsTMatrix", .....)
86                  else     new("lgTMatrix", .....)
87              }
88          })
89    }# not yet
90
91  setAs("sparseMatrix", "graph", function(from) as(from, "graphNEL"))  setAs("sparseMatrix", "graph", function(from) as(from, "graphNEL"))
92  setAs("sparseMatrix", "graphNEL",  setAs("sparseMatrix", "graphNEL",
93        function(from) as(as(from, "dgTMatrix"), "graphNEL"))        function(from) as(as(from, "TsparseMatrix"), "graphNEL"))
94  setAs("dgTMatrix", "graphNEL",  setAs("TsparseMatrix", "graphNEL",
95        function(from) {        function(from) {
96            d <- dim(from)            d <- dim(from)
97            if(d[1] != d[2])            if(d[1] != d[2])
# Line 40  Line 100
100            if(n == 0) return(new("graphNEL"))            if(n == 0) return(new("graphNEL"))
101            if(is.null(rn <- dimnames(from)[[1]]))            if(is.null(rn <- dimnames(from)[[1]]))
102                rn <- as.character(1:n)                rn <- as.character(1:n)
103              from <- uniq(from) ## Need to 'uniquify' the triplets!
104            if(isSymmetric(from)) { # because it's "dsTMatrix" or otherwise            if(isSymmetric(from)) { # because it's "dsTMatrix" or otherwise
## Need to 'uniquify' the triplets!
105                upper <- from@i <= from@j                upper <- from@i <= from@j
106                graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),                ft1 <- cbind(from@i + 1:1, from@j + 1:1)
107                  graph::ftM2graphNEL(rbind(ft1, ft1[, 2:1]),
108                                    W = from@x, V=rn, edgemode="undirected")                                    W = from@x, V=rn, edgemode="undirected")
109
110            } else { ## not symmetric            } else { ## not symmetric
# Line 51  Line 112
112                graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),                graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),
113                                    W = from@x, V=rn, edgemode="directed")                                    W = from@x, V=rn, edgemode="directed")
114            }            }
115            stop("'dgTMatrix -> 'graphNEL' method is not yet implemented")            ## stop("'dgTMatrix -> 'graphNEL' method is not yet implemented")
## new("graphNEL", nodes = paste(1:n) , edgeL = ...)
116        })        })
117
##! }#--not_yet
118
119
120

Legend:
 Removed from v.1270 changed lines Added in v.1271