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