https://github.com/cran/Matrix
Tip revision: 5867f1c6c728f0a09da3ebda6ed3a365084e0fc5 authored by Douglas Bates on 19 January 2006, 00:00:00 UTC
version 0.995-2
version 0.995-2
Tip revision: 5867f1c
Tsparse.R
#### "TsparseMatrix" : Virtual class of sparse matrices in triplet-format
### "[" :
### -----
## Want to allow 'numeric', 'logical' and 'character' indices
## Test for numeric/logical/character
## method-*internally* ; this is not strictly OO, but allows to use
## the following utility and hence much more compact code.
.ind.prep <- function(xi, i, margin, di, dn)
{
## Purpose: do the ``common things'' for "*gTMatrix" indexing
## for 1 dimension, 'margin' ,
## and return match(.,.) + li = length of corresponding dimension
##
## i is "index"; xi = "x@i"; margin in {1,2};
## di = dim(x) { used when i is "logical" }
## dn = dimnames(x) { used when i is character }
dn <- dn[[margin]]
has.dn <- is.character(dn)
if(is(i, "numeric")) {
storage.mode(i) <- "integer"
if(any(ineg <- i < 0:0)) {
if(any(i > 0:0))
stop("you cannot mix negative and positive indices")
i0 <- (0:(di[margin]-1:1))[i]
} else {
i0 <- i - 1:1 # transform to 0-indexing
}
if(has.dn) dn <- dn[i]
}
else if (is(i, "logical")) {
i0 <- (0:(di[margin]-1:1))[i]
if(has.dn) dn <- dn[i]
} else { ## character
if(!has.dn)
stop(gettextf("no 'dimnames[[%d]]': cannot use character indexing"),
margin, domain = NA)
i0 <- match(i, dn, nomatch=0)
dn <- dn[i0]
i0 <- i0 - 1:1
}
list(m = match(xi, i0, nomatch=0), li = length(i0), dn = dn)
}
## Otherwise have to write methods for all possible combinations of
## (i , j) \in
## (numeric, logical, character, missing) x (numeric, log., char., miss.)
## Select rows
setMethod("[", signature(x = "TsparseMatrix", i = "index", j = "missing",
drop = "logical"),
function (x, i, j, ..., drop) { ## select rows
ip <- .ind.prep(x@i, i, 1, dim(x), dimnames(x))
x@Dim[1] <- ip$li
x@Dimnames[1] <- ip$dn
sel <- ip$m > 0
x@i <- ip$m[sel] - 1:1
x@j <- x@j[sel]
if (!is(x, "lsparseMatrix")) x@x <- x@x[sel]
if (drop && any(x@Dim == 1:1)) drop(as(x,"matrix")) else x
})
## Select columns
setMethod("[", signature(x = "TsparseMatrix", i = "missing", j = "index",
drop = "logical"),
function (x, i, j, ..., drop) { ## select columns
ip <- .ind.prep(x@j, j, 2, dim(x), dimnames(x))
x@Dim[2] <- ip$li
x@Dimnames[2] <- ip$dn
sel <- ip$m > 0
x@i <- x@i[sel]
x@j <- ip$m[sel] - 1:1
if (!is(x, "lsparseMatrix")) x@x <- x@x[sel]
if (drop && any(x@Dim == 1:1)) drop(as(x,"matrix")) else x
})
## [.data.frame has : drop = if (missing(i)) TRUE else length(cols) == 1)
setMethod("[", signature(x = "TsparseMatrix",
i = "index", j = "index", drop = "logical"),
function (x, i, j, ..., drop)
{
## (i,j, drop) all specified
di <- dim(x)
dn <- dimnames(x)
ip1 <- .ind.prep(x@i, i, 1, di, dn)
ip2 <- .ind.prep(x@j, j, 2, di, dn)
x@Dim <- nd <- c(ip1$li, ip2$li)
x@Dimnames <- list(ip1$dn, ip2$dn)
sel <- ip1$m > 0:0 & ip2$m > 0:0
x@i <- ip1$m[sel] - 1:1
x@j <- ip2$m[sel] - 1:1
if (!is(x, "lsparseMatrix")) x@x <- x@x[sel]
if (drop && any(nd == 1)) drop(as(x,"matrix")) else x
})
setMethod("crossprod", signature(x = "TsparseMatrix", y = "missing"),
function(x, y = NULL)
.Call("Csparse_crossprod", x, trans = FALSE, triplet = TRUE,
PACKAGE = "Matrix"))
setMethod("tcrossprod", signature(x = "TsparseMatrix", y = "missing"),
function(x, y = NULL)
.Call("Csparse_crossprod", x, trans = TRUE, triplet = TRUE,
PACKAGE = "Matrix"))
setAs("TsparseMatrix", "CsparseMatrix",
function(from) .Call("Tsparse_to_Csparse", x, PACKAGE = "Matrix"))