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 925 - (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 :     symmetric = (from@edgemode == "undirected"))
24 : bates 862 })
25 : maechler 871 setAs("graph", "sparseMatrix",
26 :     function(from) as(as(from,"graphNEL"), "sparseMatrix"))
27 : maechler 687
28 : maechler 908 ##! if(FALSE) {##--- not yet
29 : maechler 687
30 : maechler 871 setAs("sparseMatrix", "graph", function(from) as(from, "graphNEL"))
31 :     setAs("sparseMatrix", "graphNEL",
32 :     function(from) as(as(from, "dgTMatrix"), "graphNEL"))
33 :     setAs("dgTMatrix", "graphNEL",
34 :     function(from) {
35 : maechler 908 d <- dim(from)
36 : maechler 871 if(d[1] != d[2])
37 :     stop("only square matrices can be used as incidence matrices for grphs")
38 :     n <- d[1]
39 :     if(n == 0) return(new("graphNEL"))
40 : maechler 908 if(is.null(rn <- dimnames(from)[[1]]))
41 :     rn <- as.character(1:n)
42 :     if(isSymmetric(from)) { # because it's "dsTMatrix" or otherwise
43 :     ## Need to 'uniquify' the triplets!
44 :     upper <- from@i <= from@j
45 :     graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),
46 :     W = from@x, V=rn, edgemode="undirected")
47 :    
48 :     } else { ## not symmetric
49 :    
50 :     graph::ftM2graphNEL(cbind(from@i + 1:1, from@j + 1:1),
51 :     W = from@x, V=rn, edgemode="directed")
52 :     }
53 : maechler 871 stop("'dgTMatrix -> 'graphNEL' method is not yet implemented")
54 :     ## new("graphNEL", nodes = paste(1:n) , edgeL = ...)
55 :     })
56 :    
57 : maechler 908 ##! }#--not_yet
58 : maechler 871
59 :    
60 :    
61 : maechler 868 ### Subsetting -- basic things (drop = "missing") are done in ./Matrix.R
62 : maechler 687
63 : maechler 925 ### FIXME : we defer to the "*gT" -- conveniently, but not efficient for gC !
64 : maechler 687
65 : maechler 925 ## [dl]sparse -> [dl]gT -- treat both in one via superclass
66 :     ## -- more useful when have "z" (complex) and even more
67 : maechler 687
68 : maechler 925 setMethod("[", signature(x = "sparseMatrix", i = "index", j = "missing",
69 : maechler 868 drop = "logical"),
70 : maechler 925 function (x, i, j, drop) {
71 :     cl <- class(x)
72 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
73 :     x <- callGeneric(x = as(x, viaCl), i=i, drop=drop)
74 :     if(!is(x,"Matrix")) x else as(x, cl)
75 :     })
76 : maechler 687
77 : maechler 925 setMethod("[", signature(x = "sparseMatrix", i = "missing", j = "index",
78 : maechler 868 drop = "logical"),
79 : maechler 925 function (x, i, j, drop) {
80 :     cl <- class(x)
81 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
82 :     x <- callGeneric(x = as(x, viaCl), j=j, drop=drop)
83 :     if(!is(x,"Matrix")) x else as(x, cl)
84 :     })
85 : maechler 868
86 : maechler 925 setMethod("[", signature(x = "sparseMatrix",
87 : maechler 886 i = "index", j = "index", drop = "logical"),
88 : maechler 925 function (x, i, j, drop) {
89 :     cl <- class(x)
90 :     viaCl <- if(is(x,"dMatrix")) "dgTMatrix" else "lgTMatrix"
91 :     x <- callGeneric(x = as(x, viaCl), i=i, j=j, drop=drop)
92 :     if(!is(x,"Matrix")) x else as(x, cl)
93 :     })
94 : maechler 868
95 :    
96 :    
97 :    
98 : maechler 687 ### --- show() method ---
99 :    
100 :     emptyColnames <- function(x)
101 :     {
102 :     ## Useful for compact printing of (parts) of sparse matrices
103 :     ## possibly dimnames(x) "==" NULL :
104 :     dimnames(x) <- list(dimnames(x)[[1]], rep("", dim(x)[2]))
105 :     x
106 :     }
107 :    
108 :     prSpMatrix <- function(object, zero.print = ".")
109 :     {
110 :     stopifnot(is(object, "sparseMatrix"))
111 :     m <- as(object, "matrix")
112 :     x <- apply(m, 2, format)
113 :     if(is.null(dim(x))) {# e.g. in 1 x 1 case
114 :     dim(x) <- dim(m)
115 :     dimnames(x) <- dimnames(m)
116 :     }
117 :     x <- emptyColnames(x)
118 :     if(is.logical(zero.print))
119 :     zero.print <- if(zero.print) "0" else " "
120 :     ## FIXME: show only "structural" zeros as 'zero.print', not all of them..
121 :     x[m == 0.] <- zero.print
122 : maechler 868 if(is(object,"lsparseMatrix"))
123 :     x[m] <- "|"
124 : maechler 687 print(noquote(x))
125 :     invisible(object)
126 :     }
127 :    
128 :     setMethod("show", signature(object = "sparseMatrix"),
129 :     function(object) {
130 :     d <- dim(object)
131 :     cl <- class(object)
132 :     cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))
133 :    
134 :     maxp <- getOption("max.print")
135 :     if(prod(d) <= maxp)
136 :     prSpMatrix(object)
137 :     else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:
138 :     nr <- maxp %/% d[2]
139 :     n2 <- ceiling(nr / 2)
140 :     nR <- d[1] # nrow
141 :     prSpMatrix(object[seq(length = min(nR, max(1, n2))), drop = FALSE])
142 :     cat("\n ..........\n\n")
143 :     prSpMatrix(object[seq(to = nR, length = min(max(1, nr-n2), nR)),
144 :     drop = FALSE])
145 :     invisible(object)
146 :     }
147 :     })
148 : maechler 886
149 :    
150 :     ## not exported:
151 :     setMethod("isSymmetric", signature(object = "sparseMatrix"),
152 :     function(object, ...) {
153 :     ## pretest: is it square?
154 :     d <- dim(object)
155 :     if(d[1] != d[2]) return(FALSE)
156 :     ## else slower test
157 :     if (is(object("dMatrix")))
158 :     ## use gC; "T" (triplet) is *not* unique!
159 :     isTRUE(all.equal(as(object, "dgCMatrix"),
160 :     as(t(object), "dgCMatrix"), ...))
161 :     else if (is(object("lMatrix")))
162 :     ## test for exact equality; FIXME(?): identical() too strict?
163 :     identical(as(object, "lgCMatrix"),
164 :     as(t(object), "lgCMatrix"))
165 :     else stop("not yet implemented")
166 :     })
167 : maechler 925
168 :    

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