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
142
143
144
145
|
### Simple fallback methods for all dense matrices
### These are "cheap" to program, but potentially far from efficient;
### Methods for specific subclasses will overwrite these:
setAs("ANY", "denseMatrix", function(from) Matrix(from, sparse=FALSE))
## dense to sparse:
setAs("denseMatrix", "dsparseMatrix",
## MM thought that as() will take the ``closest'' match; but that fails!
## function(from) as(as(from, "dgeMatrix"), "dsparseMatrix"))
function(from) as(as(from, "dgeMatrix"), "dgCMatrix"))
setAs("denseMatrix", "CsparseMatrix",
function(from) {
cl <- class(from)
notGen <- !is(from, "generalMatrix")
if (notGen) { ## e.g. for triangular | symmetric
## FIXME: this is a *waste* in the case of packed matrices!
if (extends(cl, "dMatrix")) from <- as(from, "dgeMatrix")
else if(extends(cl, "nMatrix")) from <- as(from, "ngeMatrix")
else if(extends(cl, "lMatrix")) from <- as(from, "lgeMatrix")
else if(extends(cl, "zMatrix")) from <- as(from, "zgeMatrix")
else stop("undefined method for class ", cl)
}
## FIXME: contrary to its name, this only works for "dge*" :
.Call(dense_to_Csparse, from)
})
setAs("denseMatrix", "TsparseMatrix",
function(from) as(as(from, "CsparseMatrix"), "TsparseMatrix"))
setMethod("show", signature(object = "denseMatrix"),
function(object) prMatrix(object))
##- ## FIXME: The following is only for the "dMatrix" objects that are not
##- ## "dense" nor "sparse" -- i.e. "packed" ones :
##- ## But these could be printed better -- "." for structural zeros.
##- setMethod("show", signature(object = "dMatrix"), prMatrix)
##- ## and improve this as well:
##- setMethod("show", signature(object = "pMatrix"), prMatrix)
##- ## this should now be superfluous [keep for safety for the moment]:
## Using "index" for indices should allow
## integer (numeric), logical, or character (names!) indices :
## use geClass() when 'i' or 'j' are missing:
## since symmetric, triangular, .. will not be preserved anyway:
setMethod("[", signature(x = "denseMatrix", i = "index", j = "missing",
drop = "logical"),
function (x, i, drop) {
r <- as(x, "matrix")[i, , drop=drop]
if(is.null(dim(r))) r else as(r, geClass(x))
})
setMethod("[", signature(x = "denseMatrix", i = "missing", j = "index",
drop = "logical"),
function (x, j, drop) {
r <- as(x, "matrix")[, j, drop=drop]
if(is.null(dim(r))) r else as(r, geClass(x))
})
setMethod("[", signature(x = "denseMatrix", i = "index", j = "index",
drop = "logical"),
function (x, i, j, drop) {
r <- callGeneric(x = as(x, "matrix"), i=i, j=j, drop=drop)
if(is.null(dim(r)))
r
else {
cl <- class(x)
if(extends(cl, "symmetricMatrix") &&
length(i) == length(j) && all(i == j))
as(r, cl) ## keep original symmetric class
else as_geClass(r, cl)
}
})
## Now the "[<-" ones --- see also those in ./Matrix.R
## It's recommended to use setReplaceMethod() rather than setMethod("[<-",.)
## even though the former is currently just a wrapper for the latter
## FIXME: 1) These are far from efficient
## ----- 2) value = "numeric" is only ok for "ddense*"
setReplaceMethod("[", signature(x = "denseMatrix", i = "index", j = "missing",
value = "replValue"),
function (x, i, value) {
r <- as(x, "matrix")
r[i, ] <- value
as(r, geClass(x))
})
setReplaceMethod("[", signature(x = "denseMatrix", i = "missing", j = "index",
value = "replValue"),
function (x, j, value) {
r <- as(x, "matrix")
r[, j] <- value
as(r, geClass(x))
})
setReplaceMethod("[", signature(x = "denseMatrix", i = "index", j = "index",
value = "replValue"),
function (x, i, j, value) {
r <- as(x, "matrix")
r[i, j] <- value
as_geClass(r, class(x)) ## was as(r, class(x))
})
setMethod("isSymmetric", signature(object = "denseMatrix"),
function(object, tol = 100*.Machine$double.eps) {
## pretest: is it square?
d <- dim(object)
if(d[1] != d[2]) return(FALSE)
## else slower test
if (is(object,"dMatrix"))
isTRUE(all.equal(as(object, "dgeMatrix"),
as(t(object), "dgeMatrix"), tol = tol))
else if (is(object, "nMatrix"))
identical(as(object, "ngeMatrix"),
as(t(object), "ngeMatrix"))
else if (is(object, "lMatrix"))# not possible currently
## test for exact equality; FIXME(?): identical() too strict?
identical(as(object, "lgeMatrix"),
as(t(object), "lgeMatrix"))
else if (is(object, "zMatrix"))
stop("'zMatrix' not yet implemented")
else if (is(object, "iMatrix"))
stop("'iMatrix' not yet implemented")
})
setMethod("isTriangular", signature(object = "triangularMatrix"),
function(object, ...) TRUE)
setMethod("isTriangular", signature(object = "denseMatrix"), isTriMat)
setMethod("isDiagonal", signature(object = "denseMatrix"), .is.diagonal)
.as.dge.Fun <- function(x, na.rm = FALSE, dims = 1) {
x <- as(x, "dgeMatrix")
callGeneric()
}
setMethod("colSums", signature(x = "denseMatrix"), .as.dge.Fun)
setMethod("colMeans", signature(x = "denseMatrix"), .as.dge.Fun)
setMethod("rowSums", signature(x = "denseMatrix"), .as.dge.Fun)
setMethod("rowMeans", signature(x = "denseMatrix"), .as.dge.Fun)
|
