SCM

SCM Repository

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

Diff of /pkg/R/sparseMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge