The R Project SVN R-packages

#### All Methods in relation with the sparseVector (sub)classes


# atomicVector : classUnion (logical,integer,double,....)
setAs("atomicVector", "sparseVector",
      function(from) {
      n <- length(from)
      r <- new(paste(.V.kind(from), "sparseVector", sep=''), length = n)
      ii <- from != 0
      r@x <- from[ii]
      r@i <- seq_len(n)[ii]
      r
      })


for(T in c("d","i","l","z")) {
    setAs("xsparseVector", paste(T, "sparseVector", sep=''),
          function(from) {
              from@x <- as(from@x, .type.kind[T])
              ## and now "the hack":
              class(from) <- paste(T, "sparseVector", sep='')
              from
          })
}

setAs("sparseVector", "nsparseVector",
      function(from) {
          if(any(is.na(from@x)))
              stop("cannot coerce 'NA's to \"nsparseVector\"")
          new("nsparseVector", i = from@i, length = from@length)
      })

sp2vec <- function(x, mode = .type.kind[substr(cl, 1,1)]) {
    cl <- class(x)
    r <- vector(mode, x@length)
    r[x@i] <-
    if(cl != "nsparseVector") { # cheap test for 'has x slot'
        if(is(x@x, mode)) x@x else as(x@x, mode)
    } else TRUE
    r
}

setAs("sparseVector", "vector", function(from) sp2vec(from))

setMethod("as.vector", signature(x = "sparseVector", mode = "missing"),
      sp2vec)
setMethod("as.vector", signature(x = "sparseVector", mode = "character"),
      sp2vec)

setMethod("as.numeric", "sparseVector", function(x) sp2vec(x, mode = "double"))

## the "catch all remaining" method:
setAs("ANY", "sparseVector",
      function(from) as(as.vector(from), "sparseVector"))

setAs("diagonalMatrix", "sparseVector",
      function(from) {
      kind <- .M.kind(from) ## currently only "l" and "d" --> have 'x'
      n <- nrow(from)
      new(paste(kind, "sparseVector", sep=''),
          length = n, # 1-based indexing
          i = as.integer(seq(1L, by = n+1, length.out = n)),
          x = if(from@diag != "U") from@x else
          switch(kind, "d" = 1, "l" = TRUE, "i" = 1L, "z" = 1+0i))
     })

setAs("sparseMatrix", "sparseVector",
      function(from) as(as(from, "TsparseMatrix"), "sparseVector"))

setAs("TsparseMatrix", "sparseVector",
      function(from) {
      d <- dim(from)
      n <- d[1] * d[2] # length of vector
      kind <- .M.kind(from)
      if(is_duplicatedT(from, nr = d[1]))
          from <- uniqTsparse(from)
      r <- new(paste(kind, "sparseVector", sep=''), length = n)
      r@i <- 1L + from@i + d[1] * from@j
      if(kind != "n") ## have 'x' slot
          r@x <- from@x
      r
      })



## TODO -- also want  (sparseVector, dim) |---> sparseMatrix
##  because of (nrow,ncol) specification can not (?)  use as(.).
##  Hence use  Matrix(.) ?  or my  spMatrix(.) ?

## For now, define this utility function:
spV2M <- function (x, nrow, ncol, byrow = FALSE)
{
    ## Purpose:  sparseVector --> sparseMatrix  constructor
    ## ----------------------------------------------------------------------
    ## Arguments: x: "sparseVector" object
    ##      nrow, ncol, byrow: as for matrix() or Matrix()
    ## ----------------------------------------------------------------------
    ## Author: Martin Maechler, Date: 11 May 2007

    cx <- class(x)
    stopifnot(extends(cx, "sparseVector"))
    if(!missing(ncol)) { ncol <- as.integer(ncol)
             if(ncol <= 0) stop("'ncol' must be >= 1") }
    if(!missing(nrow)) { nrow <- as.integer(nrow)
             if(nrow <= 0) stop("'nrow' must be >= 1") }
    n <- length(x)
    if(missing(nrow)) {
    if(missing(ncol)) { ## both missing: --> (n x 1)
        ncol <- 1L
        nrow <- n
    } else {
        if(n %% ncol != 0) warning("'ncol' is not a factor of length(x)")
        nrow <- as.integer(ceiling(n / ncol))
    }
    } else {
    if(missing(ncol)) {
        if(n %% nrow != 0) warning("'nrow' is not a factor of length(x)")
        ncol <- as.integer(ceiling(n / nrow))
    } else { ## both nrow and ncol specified
        if(ncol * nrow <  n) stop("nrow * ncol < length(x)")
        if(ncol * nrow != n) warning("nrow * ncol != length(x)")
    }
    }
    ## now nrow * ncol >= n
    ##     ~~~~~~~~~~~~~~~~
    cld <- getClassDef(cx)
    kind <- .M.kindC(cld)       # "d", "n", "l", "z", ...
    has.x <- kind != "n"
    r <- new(paste(kind,"gTMatrix", sep=''), Dim = c(nrow, ncol))
    ## now "compute"  the (i,j,x) slots given x@(i,x)
    i0 <- x@i - 1L
    if(byrow) {
    r@j <- i0 %% ncol
    r@i <- i0 %/% ncol
    } else {                # default{byrow = FALSE}
    r@i <- i0 %% nrow
    r@j <- i0 %/% nrow
    }
    if(has.x) r@x <- x@x
    r
}

setMethod("length", "sparseVector", function(x) x@length)

setMethod("show", signature(object = "sparseVector"),
   function(object) {
       n <- object@length
       cl <- class(object)
       cat(sprintf('sparse vector (nnz/length = %d/%d) of class "%s"\n',
           length(object@i), n, cl))
       maxp <- max(1, getOption("max.print"))
       if(n <= maxp) {
       prSpVector(object, maxp = maxp)
       } else { # n > maxp : will cut length of what we'll display :
       ## cannot easily show head(.) & tail(.) because of "[1] .." printing of tail
       prSpVector(object[seq_len(maxp)], maxp = maxp)
       cat(" ............................",
           "\n ........suppressing ", n - maxp,
           " entries in show(); maybe adjust 'options(max.print= *)'",
           "\n ............................\n\n", sep='')
       }
       invisible(object)
   })

prSpVector <- function(x, digits = getOption("digits"),
            maxp = getOption("max.print"), zero.print = ".")
{
    cld <- getClassDef(cl <- class(x))
    stopifnot(extends(cld, "sparseVector"), maxp >= 1)
    if(is.logical(zero.print))
    zero.print <- if(zero.print) "0" else " "
##     kind <- .M.kindC(cld)
##     has.x <- kind != "n"
    n <- x@length
    if(n > maxp) {# n > maxp =: nn : will cut length of what we'll display :
    x <- x[seq_len(maxp)] # need "[" to work ...
    n <- as.integer(maxp)
    }
    xi <- x@i
    logi <- extends(cld, "lsparseVector") || extends(cld, "nsparseVector")
    cx <- if(logi) rep.int("N", n) else character(n)
    cx[ -xi ] <- zero.print
    cx[  xi ] <- {
    if(logi) "|" else
    ## numeric (or --not yet-- complex): 'has.x' in any cases
    format(x@x, digits = digits)
    }
    ## right = TRUE : cheap attempt to get better "." alignment
    print(cx, quote = FALSE, right = TRUE, max = maxp)
    invisible(x) # TODO? in case of n > maxp, "should" return original x
}

## This is a simplified intI() {-> ./Tsparse.R } -- for sparseVector indexing:
intIv <- function(i, n)
{
    ## Purpose: translate numeric | logical index     into  1-based integer
    ## --------------------------------------------------------------------
    ## Arguments: i: index vector (numeric | logical)
    ##        n: array extent { ==  length(.) }
    if(missing(i))
    seq_len(n)
    else if(is(i, "numeric")) {
    storage.mode(i) <- "integer"
    if(any(i < 0L)) {
        if(any(i > 0L))
        stop("you cannot mix negative and positive indices")
        seq_len(n)[i]
    } else {
        if(length(i) && max(i) > n)
        stop("indexing out of range 0:",n)
        if(any(z <- i == 0))
        i <- i[!z]
        i
    }
    }
    else if (is(i, "logical")) {
    seq_len(n)[i]
    } else stop("index must be numeric or logical for 'sparseVector' indexing")
}


setMethod("[", signature(x = "sparseVector", i = "index"),
      function (x, i, j, ..., drop) {
          cld <- getClassDef(class(x))
          has.x <- !extends(cld, "nsparseVector")
          n <- x@length
          ii <- intIv(i, n)
          anyDup <- any(iDup <- duplicated(ii))
          m <- match(x@i, ii, nomatch = 0)
          sel <- m > 0L
          x@length <- length(ii)
          x@i <- m[sel]
          if(anyDup) {
          i.i <- match(ii[iDup], ii)
          jm <- lapply(i.i, function(.) which(. == m))
          sel <- c(which(sel), unlist(jm))
          x@i <- c(x@i, rep.int(which(iDup), sapply(jm, length)))
          }
          if (has.x)
          x@x <- x@x[sel]
          x
      })

## This is much analogous to replTmat in ./Tsparse.R:
replSPvec <- function (x, i, value)
{
    n <- x@length
    ii <- intIv(i, n)
    lenRepl <- length(ii)
    lenV <- length(value)
    if(lenV == 0) {
    if(lenRepl != 0)
        stop("nothing to replace with")
    else return(x)
    }
    ## else: lenV := length(value) > 0
    if(lenRepl %% lenV != 0)
    stop("number of items to replace is not a multiple of replacement length")
    anyDup <- any(duplicated(ii))
    if(anyDup) { ## multiple *replacement* indices: last one wins
    ## TODO: in R 2.6.0 use  duplicate(*, fromLast=TRUE)
    ir <- lenRepl:1
    keep <- match(ii, ii[ir]) == ir
    ii <- ii[keep]
    lenV <- length(value <- rep(value, length = lenRepl)[keep])
    lenRepl <- length(ii)
    }

    cld <- getClassDef(class(x))
    has.x <- !extends(cld, "nsparseVector")
    m <- match(x@i, ii, nomatch = 0)
    sel <- m > 0L

    ## the simplest case
    if(all0(value)) { ## just drop the non-zero entries
    if(any(sel)) { ## non-zero there
        x@i <- x@i[!sel]
        if(has.x)
        x@x <- x@x[!sel]
    }
    return(x)

    }
    ## else --  some( value != 0 ) --
    if(lenV > lenRepl)
    stop("too many replacement values")
    else if(lenV < lenRepl)
    value <- rep(value, length = lenRepl)
    ## now:  length(value) == lenRepl

    v0 <- is0(value)
    ## value[1:lenRepl]:  which are structural 0 now, which not?

    if(any(sel)) {
    ## indices of non-zero entries -- WRT to subvector
    iN0 <- m[sel] ## == match(x@i[sel], ii)

    ## 1a) replace those that are already non-zero with new val.
    vN0 <- !v0[iN0]
    if(any(vN0) && has.x)
        x@x[sel][vN0] <- value[iN0[vN0]]

    ## 1b) replace non-zeros with 0 --> drop entries
    if(any(!vN0)) {
        i <- which(sel)[!vN0]
        if(has.x)
        x@x <- x@x[-i]
        x@i <- x@i[-i]
    }
    iI0 <- if(length(iN0) < lenRepl)
        seq_len(lenRepl)[-iN0]
    } else iI0 <- seq_len(lenRepl)

    if(length(iI0) && any(vN0 <- !v0[iI0])) {
    ## 2) add those that were structural 0 (where value != 0)
    ij0 <- iI0[vN0]
    x@i <- c(x@i, ii[ij0])
    if(has.x)
        x@x <- c(x@x, value[ij0])
    }
    x

}

setReplaceMethod("[", signature(x = "sparseVector", i = "index", j = "missing",
                value = "replValue"),
         replSPvec)



## a "method" for c(<(sparse)Vector>, <(sparse)Vector>):
## FIXME: This is not exported, nor used (nor documented)
c2v <- function(x, y) {
    ## these as(., "sp..V..") check input implicitly:
    cx <- class(x <- as(x, "sparseVector"))
    cy <- class(y <- as(y, "sparseVector"))
    if(cx != cy) { ## find "common" class; result does have 'x' slot
        cxy <- c(cx,cy)
        commType <- {
            if(all(cxy %in% c("nsparseVector", "lsparseVector")))
                "lsparseVector"
            else { # ==> "numeric" ("integer") or "complex"
                xslot1 <- function(u, cl.u)
                    if(cl.u != "nsparseVector") u@x[1] else TRUE
                switch(typeof(xslot1(x, cx) + xslot1(y, cy)),
                       ## "integer", "double", or "complex"
                       "integer" = "isparseVector",
                       "double" = "dsparseVector",
                       "complex" = "zsparseVector")
            }
        }
        if(cx != commType) x <- as(x, commType)
        if(cy != commType) y <- as(y, commType)
        cx <- commType
    }
    ## now *have* common type -- transform 'x' into result:
    nx <- x@length
    x@length <- nx + y@length
    x@i <- c(x@i, nx + y@i)
    if(cx != "nsparseVector")
        x@x <- c(x@x, y@x)
    x
}


### Group Methods (!)

## o "Ops" , "Arith", "Compare"  :  ---> in ./Ops.R