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
|
setAs("matrix", "lMatrix",
function(from) { storage.mode(from) <- "logical" ; Matrix(from) })
## NOTE: This is *VERY* parallel to ("dMatrix" -> "nMatrix") in ./dMatrix.R :
setAs("lMatrix", "nMatrix",
function(from) {
if(any(is.na(from@x)))
stop("\"lMatrix\" object with NAs cannot be coerced to \"nMatrix\"")
## i.e. from@x are only TRUE or FALSE
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 && !all(from@x)) {
from <- drop0(from) # was drop0(from, cld)
if(cl != (c. <- class(from)))
cld <- getClassDef(cl <- c.)
}
}
sNams <- slotNames(cld)
copyClass(from, sub("^l", "n", cl),
if(isSp) sNams[sNams != "x"] else sNams)
})
## and the reverse as well :
setAs("nMatrix", "lMatrix",
function(from) {
cld <- getClassDef(cl <- MatrixClass(class(from)))
r <- copyClass(from, sub("^n", "l", cl), slotNames(cld))
if(extends(cld, "sparseMatrix"))
r@x <- rep.int(TRUE, length(if(!extends(cld, "RsparseMatrix"))
from@i else from@j))
r
})
setAs("dMatrix", "lMatrix",
function(from) {
cld <- getClassDef(newCl <- class2(cl <- class(from), "l"))
sNams <- slotNames(cld)
r <- copyClass(from, newCl, sNames = sNams[sNams != "x"])
r@x <- as.logical(from@x)
r
})
setAs("lMatrix", "dMatrix",
function(from) {
cld <- getClassDef(cl <- MatrixClass(class(from)))
sNams <- slotNames(cld)
r <- copyClass(from, newCl = sub("^l", "d", cl),
sNames = sNams[sNams != "x"])
r@x <- as.double(from@x)
r
})
## needed at least for lsparse* :
setAs("lMatrix", "dgCMatrix",
function(from) as(as(from, "lgCMatrix"), "dgCMatrix"))
###-------------- which( <logical Matrix> ) -----------------------------------------------------
## "ldi: is both "sparseMatrix" and "lMatrix" but not "lsparseMatrix"
setMethod("which", "ldiMatrix",
function(x, arr.ind) {
n <- x@Dim[1L]
i <- if(x@diag == "U") seq_len(n) else which(x@x)
if(arr.ind) cbind(i,i, deparse.level = 0) else i + n*(i - 1L) })
whichDense <- function(x, arr.ind = FALSE) {
wh <- which(x@x) ## faster but "forbidden": .Internal(which(x@x))
if (arr.ind && !is.null(d <- dim(x)))
arrayInd(wh, d, useNames=FALSE) else wh
}
setMethod("which", "ndenseMatrix",
function(x, arr.ind) whichDense(as(x, "ngeMatrix"), arr.ind=arr.ind))
setMethod("which", "ldenseMatrix",
function(x, arr.ind) whichDense(as(x, "lgeMatrix"), arr.ind=arr.ind))
.which.via.vec <- function(m) sort.int(as(m, "sparseVector")@i, method="quick")
setMethod("which", "nsparseMatrix",
function(x, arr.ind) {
if(arr.ind) which(as(x, "TsparseMatrix"), arr.ind=TRUE)
else .which.via.vec(x)
})
setMethod("which", "lsparseMatrix",
function(x, arr.ind) {
if(arr.ind) which(as(x, "TsparseMatrix"), arr.ind=TRUE)
else which(as(x, "sparseVector"))
})
which.ngT <- function(x, arr.ind)
if(arr.ind) cbind(x@i, x@j) + 1L else .which.via.vec(x)
setMethod("which", "ngTMatrix", which.ngT)
setMethod("which", "ntTMatrix", function(x, arr.ind)
which.ngT(.Call(Tsparse_diagU2N, x), arr.ind))
setMethod("which", "nsTMatrix", function(x, arr.ind)
which.ngT(as(x, "generalMatrix"), arr.ind))
which.lgT <- function(x, arr.ind) {
iT <- is1(x@x)
if(arr.ind) cbind(x@i[iT], x@j[iT]) + 1L
else sort.int(as(x, "sparseVector")@i[iT], method="quick")
}
setMethod("which", "lgTMatrix", which.lgT)
setMethod("which", "ltTMatrix", function(x, arr.ind)
which.lgT(.Call(Tsparse_diagU2N, x), arr.ind))
setMethod("which", "lsTMatrix", function(x, arr.ind)
which.lgT(as(x, "generalMatrix"), arr.ind))
## all() methods ---> ldenseMatrix.R and lsparseMatrix.R
setMethod("any", signature(x = "lMatrix"),
function(x, ..., na.rm = FALSE)
## logical unit-triangular has TRUE diagonal:
(prod(dim(x)) >= 1 && is(x, "triangularMatrix") && x@diag == "U") ||
any(x@x, ..., na.rm = na.rm))
|
