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
146
147
|
### Define Methods that can be inherited for all subclasses
##-> "dMatrix" <--> "lMatrix" ---> ./lMatrix.R
## these two are parallel to "n <-> l" in the above :
setAs("nMatrix", "dMatrix",
function(from) {
cld <- getClassDef(cl <- MatrixClass(class(from)))
isSp <- extends(cld, "sparseMatrix")
## faster(not "nicer"): any(substr(cl,3,3) == c("C","T","R"))
sNams <- slotNames(cld)
r <- copyClass(from, sub("^n", "d", cl),
if(isSp) sNams else sNams[sNams != "x"])
r@x <- if(isSp) rep.int(1., nnzSparse(from)) else as.double(from@x)
r
})
## NOTE: This is *VERY* parallel to ("lMatrix" -> "nMatrix") in ./lMatrix.R :
setAs("dMatrix", "nMatrix",
function(from) {
if(any(is.na(from@x)))
stop("\"dMatrix\" object with NAs cannot be coerced to \"nMatrix\"")
## i.e. from@x are only TRUE (or FALSE in dense case)
cld <- getClassDef(cl <- MatrixClass(class(from)))
if(extends(cld, "diagonalMatrix")) { # have no "ndi*" etc class
cl <- class(from <- as(from, "sparseMatrix"))
isSp <- TRUE
} else {
isSp <- extends(cld, "sparseMatrix")
if(isSp && any(from@x == 0)) {
from <- drop0(from) # was drop0(from, cld)
if(cl != (c. <- class(from)))
cld <- getClassDef(cl <- c.)
}
}
sNams <- slotNames(cld)
r <- copyClass(from, sub("^d", "n", cl), sNams[sNams != "x"])
if(!isSp) # 'x' slot |--> logical
r@x <- as.logical(from@x)
r
})
## Group Methods, see ?Arith (e.g.)
## -----
## >>> More specific methods for sub-classes (sparse), use these as "catch-all":
## the non-Ops ones :
setMethod("Math2",
## Assume that Generic(u, k) |--> u for u in {0,1}
## which is true for round(), signif() ==> all structure maintained
signature(x = "dMatrix"),
function(x, digits) {
x@x <- callGeneric(x@x, digits = digits)
x
})
## at installation time:
## "max" "min" "range" "prod" "sum" "any" "all" :
summGenerics <- getGroupMembers("Summary")
## w/o "prod" & "sum":
summGener1 <- summGenerics[match(summGenerics, c("prod","sum"), 0) == 0]
## [also needs extra work in ./AllGeneric.R ] :
setMethod("Summary", signature(x = "ddenseMatrix", na.rm = "ANY"),
function(x, ..., na.rm) {
d <- x@Dim
if(any(d == 0)) return(callGeneric(numeric(0), ..., na.rm=na.rm))
clx <- getClassDef(class(x))
if(extends(clx, "generalMatrix"))
callGeneric(x@x, ..., na.rm = na.rm)
else if(extends(clx, "symmetricMatrix")) { # incl packed, pos.def.
if(.Generic %in% summGener1) {
callGeneric(if (length(x@x) < prod(d)) x@x
else x@x[indTri(d[1], upper= x@uplo == "U",
diag= TRUE)],
..., na.rm = na.rm)
} else callGeneric(as(x, "dgeMatrix")@x, ..., na.rm = na.rm)
}
else { ## triangular , packed
if(.Generic %in% summGener1) {
if(.Generic %in% c("any","all")) {
Zero <- FALSE; One <- TRUE
} else {
Zero <- 0; One <- 1
}
callGeneric(x@x, Zero, if(x@diag == "U") One, ..., na.rm = na.rm)
} else callGeneric(as(x, "dgeMatrix")@x, ..., na.rm = na.rm)
}
})
setMethod("Summary", signature(x = "dsparseMatrix", na.rm = "ANY"),
function(x, ..., na.rm)
{
ne <- prod(d <- dim(x))
if(ne == 0) return(callGeneric(numeric(0), ..., na.rm=na.rm))
l.x <- length(x@x)
if(l.x == ne) ## fully non-zero (and "general") - very rare but quick
return( callGeneric(x@x, ..., na.rm = na.rm) )
## else l.x < ne
n <- d[1]
clx <- getClassDef(class(x))
isTri <- extends(clx, "triangularMatrix")
isSym <- !isTri && extends(clx, "symmetricMatrix")
isU.tri <- isTri && x@diag == "U"
## "full": has *no* structural zero : very rare, but need to catch :
full.x <- ((isSym && l.x == choose(n+1, 2)) ||
(n == 1 && (isU.tri || l.x == 1)))
isGener1 <- .Generic %in% summGener1
if(isGener1) { ## not prod() or sum() -> no need check for symmetric
logicF <- .Generic %in% c("any","all")
## we rely on <generic>(x, NULL, y, ..) :== <generic>(x, y, ..):
callGeneric(x@x,
if(!full.x) { if(logicF) FALSE else 0 },
if(isU.tri) { if(logicF) TRUE else 1 },
..., na.rm = na.rm)
}
else { ## prod() or sum() : care for "symmetric" and U2N
if(!full.x && .Generic == "prod") {
if(any(is.na(x@x))) NaN else 0
}
else
callGeneric((if(isSym) as(x, "generalMatrix") else x)@x,
if(!full.x) 0, # one 0 <==> many 0's
if(isU.tri) rep.int(1, n),
..., na.rm = na.rm)
}
})
## "Ops" ("Arith", "Compare", "Logic") --> ./Ops.R
## -- end{group generics} -----------------------
## Methods for single-argument transformations
setMethod("zapsmall", signature = list(x = "dMatrix"),
function(x, digits = getOption("digits")) {
x@x <- zapsmall(x@x, digits)
x
})
## -- end(single-argument transformations) ------
|
