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
|
#### Triangular Packed Matrices -- Coercion and Methods
setAs("dtpMatrix", "dtrMatrix",
function(from) .Call(dtpMatrix_as_dtrMatrix, from))
if(FALSE) # now have faster "ddense" -> "dge"
setAs("dtpMatrix", "dgeMatrix",
function(from) as(as(from, "dtrMatrix"), "dgeMatrix"))
setAs("dtpMatrix", "dtTMatrix",
## FIXME this is NOT efficient:
function(from) {
x <- as(from, "TsparseMatrix")
if(is(x, "dtTMatrix"))
x
else
gt2tT(as(x, "dgTMatrix"), uplo = from@uplo, diag = from@diag)
})
setAs("dtpMatrix", "matrix",
function(from) as(as(from, "dtrMatrix"), "matrix"))
setAs("matrix", "dtpMatrix",
function(from) as(as(from, "dtrMatrix"), "dtpMatrix"))
setMethod("%*%", signature(x = "dtpMatrix", y = "ddenseMatrix"),
function(x, y) .Call(dtpMatrix_matrix_mm, x, y))
setMethod("%*%", signature(x = "dgeMatrix", y = "dtpMatrix"),
function(x, y) .Call(dgeMatrix_dtpMatrix_mm, x, y))
## DB: I don't think this is needed any more
## %*% should always work for <fooMatrix> %*% <fooMatrix>
## setMethod("%*%", signature(x = "dtpMatrix", y = "dtpMatrix"),
## function(x, y)
## ## FIXME: this is cheap; could we optimize chosing the better of
## ## callGeneric(x, as(y, "dgeMatrix")) and
## ## callGeneric(as(x "dgeMatrix"), y)) depending on their 'uplo' ?
## callGeneric(x, as(y, "dgeMatrix")))
## dtpMatrix <-> matrix : will be used by the "numeric" one
setMethod("%*%", signature(x = "dtpMatrix", y = "matrix"),
function(x, y) .Call(dtpMatrix_matrix_mm, x, y))
setMethod("%*%", signature(x = "matrix", y = "dtpMatrix"),
function(x, y) callGeneric(as(x, "dgeMatrix"), y))
## dtpMatrix <-> numeric : the auxiliary functions are R version specific!
##setMethod("%*%", signature(x = "dtpMatrix", y = "numeric"), .M.v)
##setMethod("%*%", signature(x = "numeric", y = "dtpMatrix"), .v.M)
setMethod("determinant", signature(x = "dtpMatrix", logarithm = "missing"),
function(x, logarithm, ...) determinant(x, TRUE))
setMethod("determinant", signature(x = "dtpMatrix", logarithm = "logical"),
function(x, logarithm, ...) {
dg <- diag(x)
if (logarithm) {
modulus <- sum(log(abs(dg)))
sgn <- prod(sign(dg))
} else {
modulus <- prod(dg)
sgn <- sign(modulus)
modulus <- abs(modulus)
}
attr(modulus, "logarithm") <- logarithm
val <- list(modulus = modulus, sign = sgn)
class(val) <- "det"
val
})
setMethod("diag", signature(x = "dtpMatrix"),
function(x = 1, nrow, ncol = n) .Call(dtpMatrix_getDiag, x),
valueClass = "numeric")
setMethod("norm", signature(x = "dtpMatrix", type = "character"),
function(x, type, ...)
.Call(dtpMatrix_norm, x, type),
valueClass = "numeric")
setMethod("norm", signature(x = "dtpMatrix", type = "missing"),
function(x, type, ...)
.Call(dtpMatrix_norm, x, "O"),
valueClass = "numeric")
setMethod("rcond", signature(x = "dtpMatrix", type = "character"),
function(x, type, ...)
.Call(dtpMatrix_rcond, x, type),
valueClass = "numeric")
setMethod("rcond", signature(x = "dtpMatrix", type = "missing"),
function(x, type, ...)
.Call(dtpMatrix_rcond, x, "O"),
valueClass = "numeric")
setMethod("solve", signature(a = "dtpMatrix", b="missing"),
function(a, b, ...) .Call(dtpMatrix_solve, a),
valueClass = "dtpMatrix")
setMethod("solve", signature(a = "dtpMatrix", b="ddenseMatrix"),
function(a, b, ...) .Call(dtpMatrix_matrix_solve, a, b),
valueClass = "dgeMatrix")
setMethod("solve", signature(a = "dtpMatrix", b="matrix"),
function(a, b, ...) .Call(dtpMatrix_matrix_solve, a, b),
valueClass = "dgeMatrix")
setMethod("t", signature(x = "dtpMatrix"),
function(x) as(t(as(x, "dtrMatrix")), "dtpMatrix"),
valueClass = "dtpMatrix")
setMethod("unpack", signature(x = "dtpMatrix"),
function(x, ...) as(x, "dtrMatrix"),
valueClass = "dtrMatrix")
###
|
