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
|
#### --- All method definitions for "!" (not) ---
## Divert everything to "lMatrix" and its subclasses :
setMethod("!", "Matrix", function(x) !as(x, "lMatrix"))
## -- diag ---
setMethod("!", "ldiMatrix", function(x) {
r <- copyClass(x, "lsyMatrix", c("Dim","Dimnames"))
n <- x@Dim[1]
if (n > 0) {
## off-diagonal: assign all and then reassign diagonals:
rx <- rep.int(TRUE, n * n)
## diagonal entries:
rx[1L + 0:(n - 1L) * (n + 1L)] <- {
if(x@diag == "N") !x@x else FALSE ## "U"
}
r@x <- rx
}
r
})
## -- lsparse --
setMethod("!", "lsparseMatrix",
## turns FALSE to TRUE --> dense matrix
function(x) !as(x, "denseMatrix"))# was "lgeMatrix"
## Use "Matrix" method !as(. , "lMatrix")
## setMethod("!", "nsparseMatrix",
## ## turns FALSE to TRUE --> dense matrix
## function(x) !as(x, "ngeMatrix"))
## -- ldense ---
setMethod("!", "ltrMatrix",
function(x) {
x@x <- !x@x ## And now fill one triangle with '!FALSE' results :
## TODO: the following should be .Call using
## a variation of make_array_triangular:
r <- as(x, "lgeMatrix")
n <- x@Dim[1]
if(x@diag == "U")
r@x[indDiag(n)] <- FALSE ## result has diagonal all FALSE
r@x[indTri(n, upper=x@uplo != "U")] <- TRUE
r
})
setMethod("!", "ltpMatrix", function(x) !as(x, "ltrMatrix"))
## for the other ldense* ones
setMethod("!", "lgeMatrix", function(x) { x@x <- !x@x ; x })
setMethod("!", "ldenseMatrix", function(x) {
if(is(x, "symmetricMatrix")) { # lsy | lsp
x@x <- !x@x
x
}
else ## triangular are dealt with above already : "general" here:
!as(x, "lgeMatrix")
})
## -- ndense ---
setMethod("!", "ntrMatrix",
function(x) {
x@x <- !x@x
## And now we must fill one triangle with '!FALSE' results :
## TODO: the following should be .Call using
## a variation of make_array_triangular:
r <- as(x, "ngeMatrix")
n <- x@Dim[1]
coli <- rep(1:n, each=n)
rowi <- rep(1:n, n)
Udiag <- x@diag == "U"
log.i <-
if(x@uplo == "U") {
if(Udiag) rowi >= coli else rowi > coli
} else {
if(Udiag) rowi <= coli else rowi < coli
}
r@x[log.i] <- TRUE
r
})
setMethod("!", "ntpMatrix", function(x) !as(x, "ntrMatrix"))
## for the other ldense* ones
setMethod("!", "ngeMatrix", function(x) { x@x <- !x@x ; x })
setMethod("!", "ndenseMatrix", function(x) {
if(is(x, "symmetricMatrix")) { # lsy | lsp
x@x <- !x@x
x
}
else ## triangular are dealt with above already : "general" here:
!as(x, "ngeMatrix")
})
### ---- sparseVector -----
setMethod("!", "sparseVector",
function(x) {
n <- x@length
if(2 * length(x@i) <= n)
!sp2vec(x)
else { ## sparse result
ii <- seq_len(n)[-x@i]
if((has.x <- !is(x, "nsparseVector"))) {
xx <- rep.int(TRUE, length(ii))
if((.na <- any(x.na <- is.na(x@x))) |
(.fa <- any(x.f <- !x.na & !x@x))) {
## deal with 'FALSE' and 'NA' in x slot
if(.na) {
ii <- c(ii, x@i[x.na])
xx <- c(xx, x@x[x.na])
}
if(.fa) { ## any(x.f)
x.f <- x.f & !x.na
ii <- c(ii, x@i[x.f])
xx <- c(xx, rep.int(TRUE, sum(x.f)))
}
## sort increasing in index:
i.s <- sort.list(ii)
ii <- ii[i.s]
xx <- xx[i.s]
}
}
if(has.x)
newSpV("lsparseVector", x = xx, i = ii, length = n)
else new("nsparseVector", i = ii, length = n)
}
})
|
