SCM

SCM Repository

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

Annotation of /pkg/R/sparseMatrix.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1108 - (view) (download)

1 : bates 684 ### Define Methods that can be inherited for all subclasses
2 :    
3 : maechler 925 ### Idea: Coercion between *VIRTUAL* classes -- as() chooses "closest" classes
4 :     ### ---- should also work e.g. for dense-triangular --> sparse-triangular !
5 : maechler 868 ## setAs("denseMatrix", "sparseMatrix",
6 : maechler 925 ## function(from) {
7 :     ## as(as(from, "dgeMatrix")
8 :     ## })
9 : maechler 868
10 :     ## setAs("dMatrix", "lMatrix",
11 :     ## function(from) {
12 :     ## })
13 :    
14 :    
15 : maechler 871 ## "graph" coercions -- this needs the graph package which is currently
16 :     ## ----- *not* required on purpose
17 :     ## Note: 'undirected' graph <==> 'symmetric' matrix
18 :    
19 : bates 862 setAs("graphNEL", "sparseMatrix",
20 :     function(from) {
21 : maechler 874 .Call("graphNEL_as_dgTMatrix",
22 :     from,
23 : bates 1038 symmetric = (from@edgemode == "undirected"),
24 :     PACKAGE = "Matrix")
25 : bates 862 })
26 : maechler 871 setAs("graph", "sparseMatrix",
27 :     function(from) as(as(from,"graphNEL"), "sparseMatrix"))
28 : maechler 687
29 : maechler 908 ##! if(FALSE) {##--- not yet
30 : maechler 687
31 : maechler 871 setAs("sparseMatrix", "graph", function(from) as(from, "graphNEL"))
32 :     setAs("sparseMatrix", "graphNEL",
33 :     function(from) as(as(from, "dgTMatrix"), "graphNEL"))
34 :     setAs("dgTMatrix", "graphNEL",
35 :     function(from) {
36 : maechler 908 d <- dim(from)
37 : maechler 871 if(d[1] != d[2])
38 :     stop("only square matrices can be used as incidence matrices for grphs")
39 :     n <- d[1]
40 :     if(n == 0) return(new("graphNEL"))
41 : maechler 908 if(is.null(rn <- dimnames(from)[[1]]))
42 :     rn <- as.character(1:n)
43 :     if(isSymmetric(from)) { # because it's "dsTMatrix" or otherwise
44 :     ## Need to 'uniquify' the triplets!
45 :     upper <- from@i <= from@j
46 :     graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),
47 :     W = from@x, V=rn, edgemode="undirected")
48 :    
49 :     } else { ## not symmetric
50 :    
51 :     graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),
52 :     W = from@x, V=rn, edgemode="directed")
53 :     }
54 : maechler 871 stop("'dgTMatrix -> 'graphNEL' method is not yet implemented")
55 :     ## new("graphNEL", nodes = paste(1:n) , edgeL = ...)
56 :     })
57 :    
58 : maechler 908 ##! }#--not_yet
59 : maechler 871
60 :    
61 :    
62 : maechler 868 ### Subsetting -- basic things (drop = "missing") are done in ./Matrix.R
63 : maechler 687
64 : maechler 925 ### FIXME : we defer to the "*gT" -- conveniently, but not efficient for gC !
65 : maechler 687
66 : maechler 925 ## [dl]sparse -> [dl]gT -- treat both in one via superclass
67 :     ## -- more useful when have "z" (complex) and even more
68 : maechler 687
69 : maechler 925 setMethod("[", signature(x = "sparseMatrix", i = "index", j = "missing",
70 : maechler 868 drop = "logical"),
71 : maechler 925 function (x, i, j, drop) {
72 :     cl <- class(x)
73 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
74 :     x <- callGeneric(x = as(x, viaCl), i=i, drop=drop)
75 : maechler 973 ## try_as(x, c(cl, sub("T","C", viaCl)))
76 :     if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
77 :     as(x, sub("T","C", viaCl)) else x
78 : maechler 925 })
79 : maechler 687
80 : maechler 925 setMethod("[", signature(x = "sparseMatrix", i = "missing", j = "index",
81 : maechler 868 drop = "logical"),
82 : maechler 925 function (x, i, j, drop) {
83 :     cl <- class(x)
84 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
85 :     x <- callGeneric(x = as(x, viaCl), j=j, drop=drop)
86 : maechler 973 ## try_as(x, c(cl, sub("T","C", viaCl)))
87 :     if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
88 :     as(x, sub("T","C", viaCl)) else x
89 : maechler 925 })
90 : maechler 868
91 : maechler 925 setMethod("[", signature(x = "sparseMatrix",
92 : maechler 886 i = "index", j = "index", drop = "logical"),
93 : maechler 925 function (x, i, j, drop) {
94 :     cl <- class(x)
95 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
96 :     x <- callGeneric(x = as(x, viaCl), i=i, j=j, drop=drop)
97 : maechler 973 ## try_as(x, c(cl, sub("T","C", viaCl)))
98 :     if(is(x, "Matrix") && extends(cl, "CsparseMatrix"))
99 :     as(x, sub("T","C", viaCl)) else x
100 : maechler 925 })
101 : maechler 868
102 :    
103 : maechler 956 setMethod("-", signature(e1 = "sparseMatrix", e2 = "missing"),
104 :     function(e1) { e1@x <- -e1@x ; e1 })
105 :     ## with the following exceptions:
106 :     setMethod("-", signature(e1 = "lsparseMatrix", e2 = "missing"),
107 :     function(e1) callGeneric(as(e1, "dgCMatrix")))
108 :     setMethod("-", signature(e1 = "pMatrix", e2 = "missing"),
109 :     function(e1) callGeneric(as(e1, "lgTMatrix")))
110 : maechler 868
111 : maechler 687 ### --- show() method ---
112 :    
113 :     prSpMatrix <- function(object, zero.print = ".")
114 :     {
115 :     stopifnot(is(object, "sparseMatrix"))
116 :     m <- as(object, "matrix")
117 :     x <- apply(m, 2, format)
118 :     if(is.null(dim(x))) {# e.g. in 1 x 1 case
119 :     dim(x) <- dim(m)
120 :     dimnames(x) <- dimnames(m)
121 :     }
122 :     x <- emptyColnames(x)
123 :     if(is.logical(zero.print))
124 :     zero.print <- if(zero.print) "0" else " "
125 :     ## FIXME: show only "structural" zeros as 'zero.print', not all of them..
126 :     x[m == 0.] <- zero.print
127 : maechler 868 if(is(object,"lsparseMatrix"))
128 :     x[m] <- "|"
129 : maechler 687 print(noquote(x))
130 :     invisible(object)
131 :     }
132 :    
133 :     setMethod("show", signature(object = "sparseMatrix"),
134 :     function(object) {
135 :     d <- dim(object)
136 :     cl <- class(object)
137 :     cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))
138 :    
139 :     maxp <- getOption("max.print")
140 :     if(prod(d) <= maxp)
141 :     prSpMatrix(object)
142 :     else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:
143 :     nr <- maxp %/% d[2]
144 :     n2 <- ceiling(nr / 2)
145 :     nR <- d[1] # nrow
146 :     prSpMatrix(object[seq(length = min(nR, max(1, n2))), drop = FALSE])
147 :     cat("\n ..........\n\n")
148 :     prSpMatrix(object[seq(to = nR, length = min(max(1, nr-n2), nR)),
149 :     drop = FALSE])
150 :     invisible(object)
151 :     }
152 :     })
153 : maechler 886
154 :    
155 :     ## not exported:
156 : maechler 1108 setMethod("isSymmetric", signature(object = "sparseMatrix"),
157 : maechler 973 function(object, tol = 100*.Machine$double.eps) {
158 : maechler 886 ## pretest: is it square?
159 :     d <- dim(object)
160 :     if(d[1] != d[2]) return(FALSE)
161 :     ## else slower test
162 : maechler 973 if (is(object, "dMatrix"))
163 : maechler 886 ## use gC; "T" (triplet) is *not* unique!
164 :     isTRUE(all.equal(as(object, "dgCMatrix"),
165 : maechler 973 as(t(object), "dgCMatrix"), tol = tol))
166 :     else if (is(object, "lMatrix"))
167 : maechler 886 ## test for exact equality; FIXME(?): identical() too strict?
168 :     identical(as(object, "lgCMatrix"),
169 :     as(t(object), "lgCMatrix"))
170 :     else stop("not yet implemented")
171 :     })

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