Nothing
matmultDim <- function(d.a, d.b, type = 1L) {
## Return the 'dim' of the product indicated by 'type':
## type 1: a %*% b
## 2: t(a) %*% b { crossprod}
## 3: a %*% t(b) {tcrossprod}
## after asserting that ncol(<left operand>) == nrow(<right operand>)
i.a <- 1L + (type != 2L)
i.b <- 1L + (type == 3L)
if(d.a[i.a] != d.b[i.b])
stop("non-conformable arguments")
c(d.a[-i.a], d.b[-i.b])
}
matmultDN <- function(dn.a, dn.b, type = 1L)
## Return the 'dimnames' of the product indicated by 'type':
## type 1: a %*% b
## 2: t(a) %*% b { crossprod}
## 3: a %*% t(b) {tcrossprod}
c(if(is.null(dn.a)) list(NULL) else dn.a[2L - (type != 2L)],
if(is.null(dn.b)) list(NULL) else dn.b[2L - (type == 3L)])
## METHODS FOR GENERIC: %*%
## NB: x %*% y == t(t(y) %*% t(x))
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for(.cl in c("Matrix", "sparseVector")) {
setMethod("%*%", c(x = .cl, y = "ANY"),
function(x, y)
x %*% (if(length(dim(y)) == 2L) as.matrix else as.vector)(y))
setMethod("%*%", c(x = "ANY", y = .cl),
function(x, y)
(if(length(dim(x)) == 2L) as.matrix else as.vector)(x) %*% y)
}
## .... denseMatrix ....................................................
setMethod("%*%", c(x = "denseMatrix", y = "denseMatrix"),
function(x, y)
.Call(R_dense_matmult, x, y, "N", "N"))
for(.cl in c("matrix", "vector")) {
setMethod("%*%", c(x = "denseMatrix", y = .cl),
function(x, y)
.Call(R_dense_matmult, x, y, "N", "N"))
setMethod("%*%", c(x = .cl, y = "denseMatrix"),
function(x, y)
.Call(R_dense_matmult, x, y, "N", "N"))
}
## .... CsparseMatrix ..................................................
setMethod("%*%", c(x = "CsparseMatrix", y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
setMethod("%*%", c(x = "CsparseMatrix", y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
setMethod("%*%", c(x = "CsparseMatrix", y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("%*%", c(x = "CsparseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
setMethod("%*%", c(x = .cl, y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
}
## .... RsparseMatrix ..................................................
setMethod("%*%", c(x = "RsparseMatrix", y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
setMethod("%*%", c(x = "RsparseMatrix", y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
setMethod("%*%", c(x = "RsparseMatrix", y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("%*%", c(x = "RsparseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
setMethod("%*%", c(x = .cl, y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
}
## .... TsparseMatrix ..................................................
setMethod("%*%", c(x = "TsparseMatrix", y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
setMethod("%*%", c(x = "TsparseMatrix", y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
setMethod("%*%", c(x = "TsparseMatrix", y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("%*%", c(x = "TsparseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", FALSE))
setMethod("%*%", c(x = .cl, y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", FALSE))
}
## .... diagonalMatrix .................................................
setMethod("%*%", c(x = "diagonalMatrix", y = "diagonalMatrix"),
function(x, y) {
r <- new("ddiMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
xu <- x@diag != "N"
yu <- y@diag != "N"
if(xu && yu)
r@diag <- "U"
else {
if(!xu) {
xii <- x@x
if(.M.kind(x) == "n" && anyNA(xii))
xii <- xii | is.na(xii)
}
if(!yu) {
yii <- y@x
if(.M.kind(y) == "n" && anyNA(yii))
yii <- yii | is.na(yii)
}
r@x <-
if(xu)
as.double(yii)
else if(yu)
as.double(xii)
else as.double(xii * yii)
}
r
})
for(.cl in c("CsparseMatrix", "RsparseMatrix", "TsparseMatrix",
"denseMatrix", "matrix", "vector")) {
setMethod("%*%", c(x = "diagonalMatrix", y = .cl),
function(x, y)
.Call(R_diagonal_matmult, x, y, "N", "N", FALSE))
setMethod("%*%", c(x = .cl, y = "diagonalMatrix"),
function(x, y)
.Call(R_diagonal_matmult, x, y, "N", "N", FALSE))
}
## .... indMatrix ......................................................
setMethod("%*%", c(x = "indMatrix", y = "indMatrix"),
function(x, y) {
mx <- x@margin
my <- y@margin
px <- x@perm
py <- y@perm
r <- new(if(mx == my)
"indMatrix"
else if(mx == 1L)
"dgeMatrix"
else "dgTMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
if(mx == my)
r@perm <- if(mx == 1L) py[px] else { r@margin <- 2L; px[py] }
else if(mx == 1L)
r@x <- as.double(px == rep(py, each = length(px)))
else {
r@i <- px - 1L
r@j <- py - 1L
r@x <- rep.int(1, length(px))
}
r
})
setMethod("%*%", c(x = "indMatrix", y = "Matrix"),
function(x, y) {
if(x@margin != 1L)
return(.M2kind(x, "d") %*% y)
matmultDim(x@Dim, y@Dim, type = 1L)
r <- .M2kind(y[x@perm, , drop = FALSE], ",")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%*%", c(x = "Matrix", y = "indMatrix"),
function(x, y) {
if(y@margin == 1L)
return(x %*% .M2kind(y, "d"))
matmultDim(x@Dim, y@Dim, type = 1L)
r <- .M2kind(x[, y@perm, drop = FALSE], ",")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%*%", c(x = "indMatrix", y = "matrix"),
function(x, y) {
if(x@margin != 1L)
return(.M2kind(x, "d") %*% y)
matmultDim(x@Dim, dim(y), type = 1L)
r <- .m2dense(y[x@perm, , drop = FALSE], ",ge")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%*%", c(x = "matrix", y = "indMatrix"),
function(x, y) {
if(y@margin == 1L)
return(x %*% .M2kind(y, "d"))
matmultDim(dim(x), y@Dim, type = 1L)
r <- .m2dense(x[, y@perm, drop = FALSE], ",ge")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%*%", c(x = "indMatrix", y = "vector"),
function(x, y) {
if(x@margin != 1L)
return(.M2kind(x, "d") %*% y)
k <- (d <- x@Dim)[2L]
r <-
if(k == length(y))
.m2dense(y[x@perm], ",ge")
else if(k == 1L)
.m2dense(matrix(y, d[1L], length(y), byrow = TRUE), ",ge")
else stop("non-conformable arguments")
r@Dimnames <- c(x@Dimnames[1L], list(NULL))
r
})
setMethod("%*%", c(x = "vector", y = "indMatrix"),
function(x, y) {
if(y@margin == 1L)
return(x %*% .M2kind(y, "d"))
k <- (d <- y@Dim)[1L]
r <-
if(k == length(x))
.m2dense(x[y@perm], ",ge", margin = 1L)
else if(k == 1L)
.m2dense(matrix(x, length(x), d[2L]), ",ge")
else stop("non-conformable arguments")
r@Dimnames <- c(list(NULL), y@Dimnames[2L])
r
})
## .... pMatrix ........................................................
setMethod("%*%", c(x = "pMatrix", y = "pMatrix"),
function(x, y) {
r <- new("pMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
r@perm <-
if(y@margin == 1L)
y@perm[if(x@margin == 1L) x@perm else invertPerm(x@perm)]
else {
r@margin <- 2L
(if(x@margin == 1L) invertPerm(x@perm) else x@perm)[y@perm]
}
r
})
setMethod("%*%", c(x = "pMatrix", y = "indMatrix"),
function(x, y) {
r <- new("indMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
r@perm <-
if(y@margin == 1L)
y@perm[if(x@margin == 1L) x@perm else invertPerm(x@perm)]
else {
r@margin <- 2L
(if(x@margin == 1L) invertPerm(x@perm) else x@perm)[y@perm]
}
r
})
setMethod("%*%", c(x = "indMatrix", y = "pMatrix"),
function(x, y) {
r <- new("indMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
r@perm <-
if(x@margin == 1L)
(if(y@margin == 1L) y@perm else invertPerm(y@perm))[x@perm]
else {
r@margin <- 2L
x@perm[if(y@margin == 1L) invertPerm(x@perm) else y@perm]
}
r
})
setMethod("%*%", c(x = "pMatrix", y = "Matrix"),
function(x, y) {
matmultDim(x@Dim, y@Dim, type = 1L)
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
r <- .M2kind(y[perm, , drop = FALSE], ",")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%*%", c(x = "Matrix", y = "pMatrix"),
function(x, y) {
matmultDim(x@Dim, y@Dim, type = 1L)
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .M2kind(x[, perm, drop = FALSE], ",")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%*%", c(x = "pMatrix", y = "matrix"),
function(x, y) {
matmultDim(x@Dim, dim(y), type = 1L)
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
r <- .m2dense(y[perm, , drop = FALSE], ",ge")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%*%", c(x = "matrix", y = "pMatrix"),
function(x, y) {
matmultDim(dim(x), y@Dim, type = 1L)
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .m2dense(x[, perm, drop = FALSE], ",ge")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%*%", c(x = "pMatrix", y = "vector"),
function(x, y) {
k <- x@Dim[2L]
r <-
if(k == length(y)) {
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
.m2dense(y[perm], ",ge")
}
else if(k == 1L)
.m2dense(y, ",ge", margin = 1L)
else stop("non-conformable arguments")
r@Dimnames <- c(x@Dimnames[1L], list(NULL))
r
})
setMethod("%*%", c(x = "vector", y = "pMatrix"),
function(x, y) {
k <- y@Dim[1L]
r <-
if(k == length(x)) {
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
.m2dense(x[perm], ",ge", margin = 1L)
}
else if(k == 1L)
.m2dense(x, ",ge")
else stop("non-conformable arguments")
r@Dimnames <- c(list(NULL), y@Dimnames[2L])
r
})
## .... sparseVector ...................................................
setMethod("%*%", c(x = "sparseVector", y = "sparseVector"),
function(x, y)
if((nx <- length(x)) == 1L)
.tCRT(.V2C(x * y))
else if(nx == length(y))
## else if((ny <- length(y)) == 1L)
## .V2C(x * y)
## else if(nx == ny)
.m2sparse(sum(x * y), ",gR")
else stop("non-conformable arguments"))
for(.cl in c("Matrix", "matrix")) {
setMethod("%*%", c(x = "sparseVector", y = .cl),
function(x, y)
if((k <- dim(y)[1L]) == length(x))
.tCRT(.V2C(x)) %*% y
else if(k == 1L)
.V2C(x) %*% y
else stop("non-conformable arguments"))
setMethod("%*%", c(x = .cl, y = "sparseVector"),
function(x, y)
if((k <- dim(x)[2L]) == length(y))
x %*% .V2C(y)
else if(k == 1L)
x %*% .tCRT(.V2C(y))
else stop("non-conformable arguments"))
}
setMethod("%*%", c(x = "sparseVector", y = "vector"),
function(x, y)
if((nx <- length(x)) == 1L)
.m2dense(.V2v(x * y), ",ge", margin = 1L)
else if(nx == length(y))
## else if((ny <- length(y)) == 1L)
## .m2dense(.V2v(x * y), ",ge")
## else if(nx == ny)
.m2dense(sum(x * y), ",ge")
else stop("non-conformable arguments"))
setMethod("%*%", c(x = "vector", y = "sparseVector"),
function(x, y)
if((nx <- length(x)) == 1L)
.m2dense(.V2v(x * y), ",ge", margin = 1L)
else if(nx == length(y))
## else if((ny <- length(y)) == 1L)
## .m2dense(.V2v(x * y), ",ge")
## else if(nx == ny)
.m2dense(sum(x * y), ",ge")
else stop("non-conformable arguments"))
## METHODS FOR GENERIC: %&%
## NB: x %*% y == t(t(y) %*% t(x))
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
setMethod("%&%", c(x = "ANY", y = "ANY"),
function(x, y)
(if(length(dim(x)) == 2L) as.matrix else as.vector)(x) %&%
(if(length(dim(y)) == 2L) as.matrix else as.vector)(y))
for(.cl in c("Matrix", "sparseVector", "matrix", "vector")) {
setMethod("%&%", c(x = .cl, y = "ANY"),
function(x, y)
x %&% (if(length(dim(y)) == 2L) as.matrix else as.vector)(y))
setMethod("%&%", c(x = "ANY", y = .cl),
function(x, y)
(if(length(dim(x)) == 2L) as.matrix else as.vector)(x) %&% y)
}
setMethod("%&%", c(x = "matrix", y = "matrix"),
function(x, y)
.m2sparse(x, "ngC") %&% .m2sparse(y, "ngC"))
setMethod("%&%", c(x = "matrix", y = "vector"),
function(x, y)
.m2sparse(x, "ngC") %&% y )
setMethod("%&%", c(x = "vector", y = "matrix"),
function(x, y)
x %&% .m2sparse(y, "ngC"))
setMethod("%&%", c(x = "vector", y = "vector"),
function(x, y) {
r <-
if((nx <- length(x)) == 1L)
.m2sparse(x, "ngC") %&% .m2sparse(y, "ngR", margin = 1L)
else if(nx == length(y))
## else if((ny <- length(y)) == 1L || nx == ny)
.m2sparse(x, "ngR", margin = 1L) %&% .m2sparse(y, "ngC")
else stop("non-conformable arguments")
r@Dimnames <- list(NULL, NULL)
r
})
## .... denseMatrix ....................................................
setMethod("%&%", c(x = "denseMatrix", y = "denseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
for(.cl in c("matrix", "vector")) {
setMethod("%&%", c(x = "denseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
setMethod("%&%", c(x = .cl, y = "denseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
}
## .... CsparseMatrix ..................................................
setMethod("%&%", c(x = "CsparseMatrix", y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
setMethod("%&%", c(x = "CsparseMatrix", y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
setMethod("%&%", c(x = "CsparseMatrix", y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("%&%", c(x = "CsparseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
setMethod("%&%", c(x = .cl, y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
}
## .... RsparseMatrix ..................................................
setMethod("%&%", c(x = "RsparseMatrix", y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", TRUE))
setMethod("%&%", c(x = "RsparseMatrix", y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", TRUE))
setMethod("%&%", c(x = "RsparseMatrix", y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", TRUE))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("%&%", c(x = "RsparseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", TRUE))
setMethod("%&%", c(x = .cl, y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", TRUE))
}
## .... TsparseMatrix ..................................................
setMethod("%&%", c(x = "TsparseMatrix", y = "CsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
setMethod("%&%", c(x = "TsparseMatrix", y = "RsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, y, x, "T", "T", "T", TRUE))
setMethod("%&%", c(x = "TsparseMatrix", y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("%&%", c(x = "TsparseMatrix", y = .cl),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
setMethod("%&%", c(x = .cl, y = "TsparseMatrix"),
function(x, y)
.Call(R_sparse_matmult, x, y, "N", "N", "N", TRUE))
}
## .... diagonalMatrix .................................................
setMethod("%&%", c(x = "diagonalMatrix", y = "diagonalMatrix"),
function(x, y) {
r <- new("ndiMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
xu <- x@diag != "N"
yu <- y@diag != "N"
if(xu && yu)
r@diag <- "U"
else
r@x <-
if(xu)
as.logical(y@x)
else if(yu)
as.logical(x@x)
else x@x & y@x
r
})
for(.cl in c("CsparseMatrix", "RsparseMatrix", "TsparseMatrix",
"denseMatrix", "matrix", "vector")) {
setMethod("%&%", c(x = "diagonalMatrix", y = .cl),
function(x, y)
.Call(R_diagonal_matmult, x, y, "N", "N", TRUE))
setMethod("%&%", c(x = .cl, y = "diagonalMatrix"),
function(x, y)
.Call(R_diagonal_matmult, x, y, "N", "N", TRUE))
}
## .... indMatrix ......................................................
setMethod("%&%", c(x = "indMatrix", y = "indMatrix"),
function(x, y) {
mx <- x@margin
my <- y@margin
px <- x@perm
py <- y@perm
r <- new(if(mx == my)
"indMatrix"
else if(mx == 1L)
"ngeMatrix"
else "ngTMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
if(mx == my)
r@perm <- if(mx == 1L) py[px] else { r@margin <- 2L; px[py] }
else if(mx == 1L)
r@x <- px == rep(py, each = length(px))
else {
r@i <- px - 1L
r@j <- py - 1L
}
r
})
setMethod("%&%", c(x = "indMatrix", y = "Matrix"),
function(x, y) {
if(x@margin != 1L)
return(.M2kind(x, "n") %&% y)
matmultDim(x@Dim, y@Dim, type = 1L)
r <- .M2kind(y[x@perm, , drop = FALSE], "n")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%&%", c(x = "Matrix", y = "indMatrix"),
function(x, y) {
if(y@margin == 1L)
return(x %&% .M2kind(y, "n"))
matmultDim(x@Dim, y@Dim, type = 1L)
r <- .M2kind(x[, y@perm, drop = FALSE], "n")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%&%", c(x = "indMatrix", y = "matrix"),
function(x, y) {
if(x@margin != 1L)
return(.M2kind(x, "n") %&% y)
matmultDim(x@Dim, dim(y), type = 1L)
r <- .m2dense(y[x@perm, , drop = FALSE], "nge")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%&%", c(x = "matrix", y = "indMatrix"),
function(x, y) {
if(y@margin == 1L)
return(x %&% .M2kind(y, "n"))
matmultDim(dim(x), y@Dim, type = 1L)
r <- .m2dense(x[, y@perm, drop = FALSE], "nge")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%&%", c(x = "indMatrix", y = "vector"),
function(x, y) {
if(x@margin != 1L)
return(.M2kind(x, "n") %&% y)
k <- (d <- x@Dim)[2L]
r <-
if(k == length(y))
.m2dense(y[x@perm], "nge")
else if(k == 1L)
.m2dense(matrix(y, d[1L], length(y), byrow = TRUE), "nge")
else stop("non-conformable arguments")
r@Dimnames <- c(x@Dimnames[1L], list(NULL))
r
})
setMethod("%&%", c(x = "vector", y = "indMatrix"),
function(x, y) {
if(y@margin == 1L)
return(x %&% .M2kind(y, "n"))
k <- (d <- y@Dim)[1L]
r <-
if(k == length(x))
.m2dense(x[y@perm], "nge", margin = 1L)
else if(k == 1L)
.m2dense(matrix(x, length(x), d[2L]), "nge")
else stop("non-conformable arguments")
r@Dimnames <- c(list(NULL), y@Dimnames[2L])
r
})
## .... pMatrix ........................................................
setMethod("%&%", c(x = "pMatrix", y = "pMatrix"),
function(x, y) {
r <- new("pMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
r@perm <-
if(y@margin == 1L)
y@perm[if(x@margin == 1L) x@perm else invertPerm(x@perm)]
else {
r@margin <- 2L
(if(x@margin == 1L) invertPerm(x@perm) else x@perm)[y@perm]
}
r
})
setMethod("%&%", c(x = "pMatrix", y = "indMatrix"),
function(x, y) {
r <- new("indMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
r@perm <-
if(y@margin == 1L)
y@perm[if(x@margin == 1L) x@perm else invertPerm(x@perm)]
else {
r@margin <- 2L
(if(x@margin == 1L) invertPerm(x@perm) else x@perm)[y@perm]
}
r
})
setMethod("%&%", c(x = "indMatrix", y = "pMatrix"),
function(x, y) {
r <- new("indMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 1L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 1L)
r@perm <-
if(x@margin == 1L)
(if(y@margin == 1L) y@perm else invertPerm(y@perm))[x@perm]
else {
r@margin <- 2L
x@perm[if(y@margin == 1L) invertPerm(x@perm) else y@perm]
}
r
})
setMethod("%&%", c(x = "pMatrix", y = "Matrix"),
function(x, y) {
matmultDim(x@Dim, y@Dim, type = 1L)
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
r <- .M2kind(y[perm, , drop = FALSE], "n")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%&%", c(x = "Matrix", y = "pMatrix"),
function(x, y) {
matmultDim(x@Dim, y@Dim, type = 1L)
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .M2kind(x[, perm, drop = FALSE], "n")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%&%", c(x = "pMatrix", y = "matrix"),
function(x, y) {
matmultDim(x@Dim, dim(y), type = 1L)
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
r <- .m2dense(y[perm, , drop = FALSE], "nge")
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 1L)
r
})
setMethod("%&%", c(x = "matrix", y = "pMatrix"),
function(x, y) {
matmultDim(dim(x), y@Dim, type = 1L)
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .m2dense(x[, perm, drop = FALSE], "nge")
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 1L)
r
})
setMethod("%&%", c(x = "pMatrix", y = "vector"),
function(x, y) {
k <- x@Dim[2L]
r <-
if(k == length(y)) {
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
.m2dense(y[perm], "nge")
}
else if(k == 1L)
.m2dense(y, "nge", margin = 1L)
else stop("non-conformable arguments")
r@Dimnames <- c(x@Dimnames[1L], list(NULL))
r
})
setMethod("%&%", c(x = "vector", y = "pMatrix"),
function(x, y) {
k <- y@Dim[1L]
r <-
if(k == length(x)) {
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
.m2dense(x[perm], "nge", margin = 1L)
}
else if(k == 1L)
.m2dense(x, "nge")
else stop("non-conformable arguments")
r@Dimnames <- c(list(NULL), y@Dimnames[2L])
r
})
## .... sparseVector ...................................................
setMethod("%&%", c(x = "sparseVector", y = "sparseVector"),
function(x, y) {
x <- .V2kind(.drop0(x, isM = FALSE), "n")
y <- .V2kind(.drop0(y, isM = FALSE), "n")
if((nx <- length(x)) == 1L) {
if(length(x@i) == 0L)
y@i <- integer(0L)
.tCRT(.V2C(y))
} else if(nx == length(y))
## } else if((ny <- length(y)) == 1L) {
## if(length(y@i))
## x@i <- integer(0L)
## .V2C(x)
## } else if(nx == ny)
.m2sparse(any(match(x@i, y@i, 0L)), "ngR")
else stop("non-conformable arguments")
})
for(.cl in c("Matrix", "matrix")) {
setMethod("%&%", c(x = "sparseVector", y = .cl),
function(x, y) {
x <- .V2kind(.drop0(x, isM = FALSE), "n")
if((k <- dim(y)[1L]) == length(x))
.tCRT(.V2C(x)) %&% y
else if(k == 1L)
.V2C(x) %&% y
else stop("non-conformable arguments")
})
setMethod("%&%", c(x = .cl, y = "sparseVector"),
function(x, y) {
y <- .V2kind(.drop0(y, isM = FALSE), "n")
if((k <- dim(x)[2L]) == length(y))
x %&% .V2C(y)
else if(k == 1L)
x %&% .tCRT(.V2C(y))
else stop("non-conformable arguments")
})
}
setMethod("%&%", c(x = "sparseVector", y = "vector"),
function(x, y)
.V2kind(.drop0(x, isM = FALSE), "n") %&% .m2V(y, "n"))
setMethod("%&%", c(x = "vector", y = "sparseVector"),
function(x, y)
.m2V(x, "n") %&% .V2kind(.drop0(y, isM = FALSE), "n"))
## METHODS FOR GENERIC: crossprod
## NB: t(x) %*% y == t(t(y) %*% x)
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for(.cl in c("Matrix", "sparseVector")) {
setMethod("crossprod", c(x = .cl, y = "ANY"),
function(x, y = NULL, ...)
crossprod(x, (if(length(dim(y)) == 2L) as.matrix else as.vector)(y), ...))
setMethod("crossprod", c(x = "ANY", y = .cl),
function(x, y = NULL, ...)
crossprod((if(length(dim(x)) == 2L) as.matrix else as.vector)(x), y, ...))
}
## .... denseMatrix ....................................................
setMethod("crossprod", c(x = "denseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
if(if(is.na(boolArith)) .M.kind(x) == "n" else boolArith)
.Call(R_sparse_matmult, x, y, "T", "N", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "T", "N"))
setMethod("crossprod", c(x = "denseMatrix", y = "denseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
if(if(is.na(boolArith)) .M.kind(x) == "n" && .M.kind(y) == "n" else boolArith)
.Call(R_sparse_matmult, x, y, "T", "N", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "T", "N"))
for(.cl in c("matrix", "vector")) {
setMethod("crossprod", c(x = "denseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
if(!is.na(boolArith) && boolArith)
.Call(R_sparse_matmult, x, y, "T", "N", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "T", "N"))
setMethod("crossprod", c(x = .cl, y = "denseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
if(!is.na(boolArith) && boolArith)
.Call(R_sparse_matmult, x, y, "T", "N", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "T", "N"))
}
## .... CsparseMatrix ..................................................
setMethod("crossprod", c(x = "CsparseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = "CsparseMatrix", y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = "CsparseMatrix", y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = "CsparseMatrix", y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("crossprod", c(x = "CsparseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = .cl, y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "T", "N", "T", boolArith))
}
## .... RsparseMatrix ..................................................
setMethod("crossprod", c(x = "RsparseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "T", boolArith))
setMethod("crossprod", c(x = "RsparseMatrix", y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "T", "N", "T", boolArith))
setMethod("crossprod", c(x = "RsparseMatrix", y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "T", "N", "T", boolArith))
setMethod("crossprod", c(x = "RsparseMatrix", y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "T", "N", "T", boolArith))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("crossprod", c(x = "RsparseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = .cl, y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "T", "N", "T", boolArith))
}
## .... TsparseMatrix ..................................................
setMethod("crossprod", c(x = "TsparseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = "TsparseMatrix", y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = "TsparseMatrix", y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = "TsparseMatrix", y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("crossprod", c(x = "TsparseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "T", "N", "N", boolArith))
setMethod("crossprod", c(x = .cl, y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "T", "N", "T", boolArith))
}
## .... diagonalMatrix .................................................
setMethod("crossprod", c(x = "diagonalMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...) {
boolArith <- !is.na(boolArith) && boolArith
r <- new(if(boolArith) "ndiMatrix" else "ddiMatrix")
r@Dim <- x@Dim
r@Dimnames <- x@Dimnames[c(2L, 2L)]
if(x@diag != "N")
r@diag <- "U"
else {
xii <- x@x
r@x <-
if(boolArith)
as.logical(xii)
else {
if(.M.kind(x) == "n" && anyNA(xii))
xii <- xii | is.na(xii)
as.double(xii * xii)
}
}
r
})
setMethod("crossprod", c(x = "diagonalMatrix", y = "diagonalMatrix"),
function(x, y = NULL, boolArith = NA, ...)
(if(!is.na(boolArith) && boolArith) `%&%` else `%*%`)(t(x), y))
for(.cl in c("CsparseMatrix", "RsparseMatrix", "TsparseMatrix",
"denseMatrix", "matrix", "vector")) {
setMethod("crossprod", c(x = "diagonalMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_diagonal_matmult, x, y, "T", "N", boolArith))
setMethod("crossprod", c(x = .cl, y = "diagonalMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_diagonal_matmult, x, y, "T", "N", boolArith))
}
## .... indMatrix ......................................................
setMethod("crossprod", c(x = "indMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...) {
if(x@margin != 1L)
return(tcrossprod(t(x), boolArith = boolArith, ...))
boolArith <- !is.na(boolArith) && boolArith
tt <- tabulate(x@perm, x@Dim[2L])
r <- new(if(boolArith) "ndiMatrix" else "ddiMatrix")
r@Dim <- x@Dim[c(2L, 2L)]
r@Dimnames <- x@Dimnames[c(2L, 2L)]
r@x <- if(boolArith) as.logical(tt) else as.double(tt)
r
})
for(.cl in c("Matrix", "matrix", "vector"))
setMethod("crossprod", c(x = "indMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
(if(!is.na(boolArith) && boolArith) `%&%` else `%*%`)(t(x), y))
setMethod("crossprod", c(x = "Matrix", y = "indMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(x@Dim, y@Dim, type = 2L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
if(y@margin == 1L)
r <- crossprod(x, .M2kind(y, l), boolArith = boolArith, ...)
else {
r <- .M2kind(t(x)[, y@perm, drop = FALSE], l)
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 2L)
}
r
})
setMethod("crossprod", c(x = "matrix", y = "indMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(dim(x), y@Dim, type = 2L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
if(y@margin == 1L)
r <- crossprod(x, .M2kind(y, l), boolArith = boolArith, ...)
else {
r <- .m2dense(t(x)[, y@perm, drop = FALSE], paste0(l, "ge"))
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 2L)
}
r
})
setMethod("crossprod", c(x = "vector", y = "indMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
if(y@Dim[1L] != length(x))
stop("non-conformable arguments")
l <- if(!is.na(boolArith) && boolArith) "n" else ","
if(y@margin == 1L)
r <- crossprod(x, .M2kind(y, l), boolArith = boolArith, ...)
else {
r <- .m2dense(x[y@perm], paste0(l, "ge"), margin = 1L)
r@Dimnames <- c(list(NULL), y@Dimnames[2L])
}
r
})
## .... pMatrix ........................................................
setMethod("crossprod", c(x = "pMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...) {
boolArith <- !is.na(boolArith) && boolArith
r <- new(if(boolArith) "ndiMatrix" else "ddiMatrix")
r@Dim <- x@Dim
r@Dimnames <- x@Dimnames[c(2L, 2L)]
r@diag <- "U"
r
})
setMethod("crossprod", c(x = "pMatrix", y = "pMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
r <- new("pMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 2L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 2L)
r@perm <-
if(y@margin == 1L)
y@perm[if(x@margin == 1L) invertPerm(x@perm) else x@perm]
else {
r@margin <- 2L
(if(x@margin == 1L) x@perm else invertPerm(x@perm))[y@perm]
}
r
})
setMethod("crossprod", c(x = "Matrix", y = "pMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(x@Dim, y@Dim, type = 2L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .M2kind(t(x)[, perm, drop = FALSE], l)
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 2L)
r
})
setMethod("crossprod", c(x = "matrix", y = "pMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(dim(x), y@Dim, type = 2L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .m2dense(t(x)[, perm, drop = FALSE], paste0(l, "ge"))
r@Dimnames <- matmultDN(dimnames(x), y@Dimnames, type = 2L)
r
})
setMethod("crossprod", c(x = "vector", y = "pMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
if(y@Dim[1L] != length(x))
stop("non-conformable arguments")
l <- if(!is.na(boolArith) && boolArith) "n" else ","
perm <- if(y@margin == 1L) invertPerm(y@perm) else y@perm
r <- .m2dense(x[perm], paste0(l, "ge"), margin = 1L)
r@Dimnames <- c(list(NULL), y@Dimnames[2L])
r
})
## .... sparseVector ...................................................
setMethod("crossprod", c(x = "sparseVector", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
if(if(is.na(boolArith)) .M.kind(x) == "n" else boolArith) {
if(!is.na(boolArith))
x <- .V2kind(.drop0(x, isM = FALSE), "n")
.m2sparse(length(x@i) > 0L, "nsR")
} else .m2sparse(sum(x * x), ",sR"))
setMethod("crossprod", c(x = "sparseVector", y = "sparseVector"),
function(x, y = NULL, boolArith = NA, ...)
if(if(is.na(boolArith)) .M.kind(x) == "n" && .M.kind(y) == "n" else boolArith) {
if(!is.na(boolArith)) {
x <- .V2kind(.drop0(x, isM = FALSE), "n")
y <- .V2kind(.drop0(y, isM = FALSE), "n")
}
if((nx <- length(x)) == 1L) {
if(length(x@i) == 0L)
y@i <- integer(0L)
.tCRT(.V2C(y))
} else if(nx == length(y))
.m2sparse(any(match(x@i, y@i, 0L)), "ngR")
else stop("non-conformable arguments")
} else {
if((nx <- length(x)) == 1L)
.tCRT(.V2C(x * y))
else if(nx == length(y))
.m2sparse(sum(x * y), ",gR")
else stop("non-conformable arguments")
})
for(.cl in c("Matrix", "matrix")) {
setMethod("crossprod", c(x = "sparseVector", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
crossprod(.tCRT(.V2C(x)), y, boolArith = boolArith, ...))
setMethod("crossprod", c(x = .cl, y = "sparseVector"),
function(x, y = NULL, boolArith = NA, ...)
if(dim(x)[1L] == length(y))
crossprod(x, .V2C(y) , boolArith = boolArith, ...)
else
crossprod(x, .tCRT(.V2C(y)), boolArith = boolArith, ...))
}
setMethod("crossprod", c(x = "sparseVector", y = "vector"),
function(x, y = NULL, boolArith = NA, ...)
if(!is.na(boolArith) && boolArith) {
x <- .V2kind(.drop0(x, isM = FALSE), "n")
y <- .m2V(y, "n")
if((nx <- length(x)) == 1L) {
if(length(x@i) == 0L)
y@i <- integer(0L)
.tCRT(.V2C(y))
} else if(nx == length(y))
.m2sparse(any(match(x@i, y@i, 0L)), "ngR")
else stop("non-conformable arguments")
} else {
if((nx <- length(x)) == 1L)
.m2dense(.V2v(x * y), ",ge", margin = 1L)
else if(nx == length(y))
.m2dense(sum(x * y), ",ge")
else stop("non-conformable arguments")
})
setMethod("crossprod", c(x = "vector", y = "sparseVector"),
function(x, y = NULL, boolArith = NA, ...)
if(!is.na(boolArith) && boolArith) {
x <- .m2V(x, "n")
y <- .V2kind(.drop0(y, isM = FALSE), "n")
if((nx <- length(x)) == 1L) {
if(length(x@i) == 0L)
y@i <- integer(0L)
.tCRT(.V2C(y))
} else if(nx == length(y))
.m2sparse(any(match(x@i, y@i, 0L)), "ngR")
else stop("non-conformable arguments")
} else {
if((nx <- length(x)) == 1L)
.m2dense(.V2v(x * y), ",ge", margin = 1L)
else if(nx == length(y))
.m2dense(sum(x * y), ",ge")
else stop("non-conformable arguments")
})
## METHODS FOR GENERIC: tcrossprod
## NB: x %*% t(y) == t(y %*% t(x))
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for(.cl in c("Matrix", "sparseVector")) {
setMethod("tcrossprod", c(x = .cl, y = "ANY"),
function(x, y = NULL, ...)
tcrossprod(x, (if(length(dim(y)) == 2L) as.matrix else as.vector)(y), ...))
setMethod("tcrossprod", c(x = "ANY", y = .cl),
function(x, y = NULL, ...)
tcrossprod((if(length(dim(x)) == 2L) as.matrix else as.vector)(x), y, ...))
}
## .... denseMatrix ....................................................
setMethod("tcrossprod", c(x = "denseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
if(if(is.na(boolArith)) .M.kind(x) == "n" else boolArith)
.Call(R_sparse_matmult, x, y, "N", "T", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "N", "T"))
setMethod("tcrossprod", c(x = "denseMatrix", y = "denseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
if(if(is.na(boolArith)) .M.kind(x) == "n" && .M.kind(y) == "n" else boolArith)
.Call(R_sparse_matmult, x, y, "N", "T", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "N", "T"))
for(.cl in c("matrix", "vector")) {
setMethod("tcrossprod", c(x = "denseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
if(!is.na(boolArith) && boolArith)
.Call(R_sparse_matmult, x, y, "N", "T", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "N", "T"))
setMethod("tcrossprod", c(x = .cl, y = "denseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
if(!is.na(boolArith) && boolArith)
.Call(R_sparse_matmult, x, y, "N", "T", "N", TRUE)
else
.Call(R_dense_matmult , x, y, "N", "T"))
}
## .... CsparseMatrix ..................................................
setMethod("tcrossprod", c(x = "CsparseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = "CsparseMatrix", y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = "CsparseMatrix", y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = "CsparseMatrix", y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("tcrossprod", c(x = "CsparseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = .cl, y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "N", "T", "T", boolArith))
}
## .... RsparseMatrix ..................................................
setMethod("tcrossprod", c(x = "RsparseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "T", boolArith))
setMethod("tcrossprod", c(x = "RsparseMatrix", y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "N", "T", "T", boolArith))
setMethod("tcrossprod", c(x = "RsparseMatrix", y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "N", "T", "T", boolArith))
setMethod("tcrossprod", c(x = "RsparseMatrix", y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "N", "T", "T", boolArith))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("tcrossprod", c(x = "RsparseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = .cl, y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "N", "T", "T", boolArith))
}
## .... TsparseMatrix ..................................................
setMethod("tcrossprod", c(x = "TsparseMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = "TsparseMatrix", y = "CsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = "TsparseMatrix", y = "RsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = "TsparseMatrix", y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
for(.cl in c("denseMatrix", "matrix", "vector")) {
setMethod("tcrossprod", c(x = "TsparseMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, x, y, "N", "T", "N", boolArith))
setMethod("tcrossprod", c(x = .cl, y = "TsparseMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_sparse_matmult, y, x, "N", "T", "T", boolArith))
}
## .... diagonalMatrix .................................................
setMethod("tcrossprod", c(x = "diagonalMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...) {
boolArith <- !is.na(boolArith) && boolArith
r <- new(if(boolArith) "ndiMatrix" else "ddiMatrix")
r@Dim <- x@Dim
r@Dimnames <- x@Dimnames[c(1L, 1L)]
if(x@diag != "N")
r@diag <- "U"
else {
xii <- x@x
r@x <-
if(boolArith)
as.logical(xii)
else {
if(.M.kind(x) == "n" && anyNA(xii))
xii <- xii | is.na(xii)
as.double(xii * xii)
}
}
r
})
setMethod("tcrossprod", c(x = "diagonalMatrix", y = "diagonalMatrix"),
function(x, y = NULL, boolArith = NA, ...)
(if(!is.na(boolArith) && boolArith) `%&%` else `%*%`)(x, t(y)))
for(.cl in c("CsparseMatrix", "RsparseMatrix", "TsparseMatrix",
"denseMatrix", "matrix", "vector")) {
setMethod("tcrossprod", c(x = "diagonalMatrix", y = .cl),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_diagonal_matmult, x, y, "N", "T", boolArith))
setMethod("tcrossprod", c(x = .cl, y = "diagonalMatrix"),
function(x, y = NULL, boolArith = NA, ...)
.Call(R_diagonal_matmult, x, y, "N", "T", boolArith))
}
## .... indMatrix ......................................................
setMethod("tcrossprod", c(x = "indMatrix", y = "missing"),
function(x, y = NULL, boolArith = TRUE, ...) {
if(x@margin != 1L)
return(crossprod(t(x), boolArith = boolArith, ...))
boolArith <- !is.na(boolArith) && boolArith
r <- new(if(boolArith) "ngeMatrix" else "dgeMatrix")
r@Dim <- x@Dim[c(1L, 1L)]
r@Dimnames <- x@Dimnames[c(1L, 1L)]
r@x <- as.vector(`storage.mode<-`(
.M2m(x), if(boolArith) "logical" else "double")[, x@perm])
r
})
for(.cl in c("Matrix", "matrix", "vector"))
setMethod("tcrossprod", c(x = .cl, y = "indMatrix"),
function(x, y = NULL, boolArith = NA, ...)
(if(!is.na(boolArith) && boolArith) `%&%` else `%*%`)(x, t(y)))
setMethod("tcrossprod", c(x = "indMatrix", y = "Matrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(x@Dim, y@Dim, type = 3L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
if(y@margin != 1L)
r <- tcrossprod(.M2kind(x, l), y, boolArith = boolArith, ...)
else {
r <- .M2kind(t(y)[x@perm, , drop = FALSE], l)
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 3L)
}
r
})
setMethod("tcrossprod", c(x = "indMatrix", y = "matrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(x@Dim, dim(y), type = 3L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
if(y@margin != 1L)
r <- tcrossprod(.M2kind(x, l), y, boolArith = boolArith, ...)
else {
r <- .m2dense(t(y)[x@perm, , drop = FALSE], paste0(l, "ge"))
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 3L)
}
r
})
setMethod("tcrossprod", c(x = "indMatrix", y = "vector"),
function(x, y = NULL, boolArith = NA, ...) {
d <- x@Dim
m <- d[1L]
k <- d[2L]
if(k != (if(m == 1L) length(y) else 1L))
stop("non-conformable arguments")
boolArith <- !is.na(boolArith) && boolArith
h <- if(boolArith) function(x) x | is.na(x) else as.double
r <- new(if(boolArith) "ngeMatrix" else "dgeMatrix")
r@Dim <- d <- c(m, if(m == 1L) 1L else length(y))
r@Dimnames <- c(x@Dimnames[1L], list(NULL))
r@x <-
if(m == 1L) {
if(x@margin == 1L)
h(y[x@perm])
else (if(boolArith) any else sum)(h(y))
} else {
if(x@margin == 1L)
as.vector(matrix(h(y), m, length(y), byrow = TRUE))
else {
tmp <- array(if(boolArith) FALSE else 0, d)
tmp[y@perm, ] <- h(y)
dim(tmp) <- NULL
tmp
}
}
r
})
## .... pMatrix ........................................................
setMethod("tcrossprod", c(x = "pMatrix", y = "missing"),
function(x, y = NULL, boolArith = NA, ...) {
boolArith <- !is.na(boolArith) && boolArith
r <- new(if(boolArith) "ndiMatrix" else "ddiMatrix")
r@Dim <- x@Dim
r@Dimnames <- x@Dimnames[c(1L, 1L)]
r@diag <- "U"
r
})
setMethod("tcrossprod", c(x = "pMatrix", y = "pMatrix"),
function(x, y = NULL, boolArith = NA, ...) {
r <- new("pMatrix")
r@Dim <- matmultDim(x@Dim, y@Dim, type = 2L)
r@Dimnames <- matmultDN(x@Dimnames, y@Dimnames, type = 2L)
r@perm <-
if(y@margin != 1L)
y@perm[if(x@margin == 1L) x@perm else invertPerm(x@perm)]
else {
r@margin <- 2L
(if(x@margin == 1L) invertPerm(x@perm) else x@perm)[y@perm]
}
r
})
setMethod("tcrossprod", c(x = "pMatrix", y = "Matrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(x@Dim, y@Dim, type = 3L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
r <- .M2kind(t(y)[perm, , drop = FALSE], l)
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 3L)
r
})
setMethod("tcrossprod", c(x = "pMatrix", y = "matrix"),
function(x, y = NULL, boolArith = NA, ...) {
matmultDim(x@Dim, dim(y), type = 3L)
l <- if(!is.na(boolArith) && boolArith) "n" else ","
perm <- if(x@margin == 1L) x@perm else invertPerm(x@perm)
r <- .m2dense(t(y)[perm, , drop = FALSE], paste0(l, "ge"))
r@Dimnames <- matmultDN(x@Dimnames, dimnames(y), type = 3L)
r
})
setMethod("tcrossprod", c(x = "pMatrix", y = "vector"),
function(x, y = NULL, boolArith = NA, ...) {
if(x@Dim[2L] != 1L || length(y) != 1L)
stop("non-conformable arguments")
l <- if(!is.na(boolArith) && boolArith) "n" else ","
r <- .m2dense(y, paste0(l, "ge"), margin = 1L)
r@Dimnames <- c(x@Dimnames[1L], list(NULL))
r
})
## .... sparseVector ...................................................
setMethod("tcrossprod", c(x = "sparseVector", y = "missing"),
function(x, y = NULL, boolArith = NA, ...)
tcrossprod(.V2C(x), boolArith = boolArith, ...))
setMethod("tcrossprod", c(x = "sparseVector", y = "sparseVector"),
function(x, y = NULL, boolArith = NA, ...)
(if(if(is.na(boolArith)) .M.kind(x) == "n" && .M.kind(y) == "n" else boolArith) `%&%` else `%*%`)(x, .tCRT(.V2C(y))))
for(.cl in c("Matrix", "matrix")) {
setMethod("tcrossprod", c(x = "sparseVector", y = .cl),
function(x, y = NULL, boolArith = NA, ...) {
x <- if(dim(y)[2L] == length(x)) .tCRT(.V2C(x)) else .V2C(x)
tcrossprod(x, y, boolArith = boolArith, ...)
})
setMethod("tcrossprod", c(x = .cl, y = "sparseVector"),
function(x, y = NULL, boolArith = NA, ...) {
y <- if(dim(x)[1L] == 1L) .tCRT(.V2C(y)) else .V2C(y)
tcrossprod(x, y, boolArith = boolArith, ...)
})
}
setMethod("tcrossprod", c(x = "sparseVector", y = "vector"),
function(x, y = NULL, boolArith = NA, ...) {
r <-
if(!is.na(boolArith) && boolArith)
x %&% .m2sparse(y, "ngR", margin = 1L)
else
x %*% .m2dense (y, ",ge", margin = 1L)
r@Dimnames <- list(NULL, NULL)
r
})
setMethod("tcrossprod", c(x = "vector", y = "sparseVector"),
function(x, y = NULL, boolArith = NA, ...)
(if(!is.na(boolArith) && boolArith) `%&%` else `%*%`)(x, .tCRT(.V2C(y))))
rm(.cl)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.