# SCM Repository

[matrix] Diff of /pkg/R/Auxiliaries.R
 [matrix] / pkg / R / Auxiliaries.R

# Diff of /pkg/R/Auxiliaries.R

revision 1330, Fri Jul 21 08:28:18 2006 UTC revision 1331, Sat Jul 22 17:59:53 2006 UTC
# Line 199  Line 199
199
200
201  ### There is a test on this in ../tests/dgTMatrix.R !  ### There is a test on this in ../tests/dgTMatrix.R !
uniq <- function(x) {

### Note: maybe, using
### ----    xj <- .Call(Matrix_expand_pointers, x@p)
### would be slightly more efficient than as( <dgC> , "dgTMatrix")
### but really efficient would be to use only one .Call(.) for uniq(.) !
### Try to do it particularly fast for the case where 'x' is already a 'uniq' <dgT>
202
203      if(is(x, "TsparseMatrix")) {  uniqTsparse <- function(x, class.x = c(class(x))) {
204          ## Purpose: produce a *unique* triplet representation:          ## Purpose: produce a *unique* triplet representation:
205          ##              by having (i,j) sorted and unique          ##              by having (i,j) sorted and unique
206          ## -----------------------------------------------------------          ## -----------------------------------------------------------
207          ## The following is not quite efficient {but easy to program,          ## The following is not quite efficient {but easy to program,
208          ## and both as() are based on C code      ## and as() are based on C code  (all of them?)
209          if(is(x, "dgTMatrix")) as(as(x, "dgCMatrix"), "dgTMatrix")      ##
210          else if(is(x, "lgTMatrix")) as(as(x, "lgCMatrix"), "lgTMatrix")      ## FIXME: Do it fast for the case where 'x' is already 'uniq'
211          else stop("not implemented for class", class(x))
212        switch(class.x,
213               "dgTMatrix" = as(as(x, "dgCMatrix"), "dgTMatrix"),
214               "dsTMatrix" = as(as(x, "dsCMatrix"), "dsTMatrix"),
215               "dtTMatrix" = as(as(x, "dtCMatrix"), "dtTMatrix"),
216               ## do we need this for "logical" ones, there's no sum() there!
217               "lgTMatrix" = as(as(x, "lgCMatrix"), "lgTMatrix"),
218               "lsTMatrix" = as(as(x, "lsCMatrix"), "lsTMatrix"),
219               "ltTMatrix" = as(as(x, "ltCMatrix"), "ltTMatrix"),
220               ## otherwise:
221               stop("not yet implemented for class ", clx))
222    }
223
224    ## Note: maybe, using
225    ## ----    xj <- .Call(Matrix_expand_pointers, x@p)
226    ## would be slightly more efficient than as( <dgC> , "dgTMatrix")
227    ## but really efficient would be to use only one .Call(.) for uniq(.) !
228
229      } else x  ## not 'gT' ; i.e. "uniquely" represented in any case  uniq <- function(x) {
230        if(is(x, "TsparseMatrix")) uniqTsparse(x) else x
231        ## else:  not 'Tsparse', i.e. "uniquely" represented in any case
232  }  }
233
234  if(FALSE) ## try an "efficient" version  if(FALSE) ## try an "efficient" version
# Line 287  Line 298
298      as(callGeneric(as(x, sub("^l", "d", cl))), cl)      as(callGeneric(as(x, sub("^l", "d", cl))), cl)
299  }  }
300
301    ## return "d" or "l" or "z"
302    .M.kind <- function(x, clx = class(x)) {
303        if(is.matrix(x)) { ## 'old style matrix'
304            if     (is.numeric(x)) "d"
305            else if(is.logical(x)) "l"
306            else if(is.complex(x)) "z"
307            else stop("not yet implemented for matrix w/ typeof ", typeof(x))
308        }
309        else if(extends(clx, "dMatrix")) "d"
310        else if(extends(clx, "lMatrix")) "l"
311        else if(extends(clx, "zMatrix")) "z"
312        else stop(" not yet be implemented for ", clx)
313    }
314
315    .M.shape <- function(x, clx = class(x)) {
316        if(is.matrix(x)) { ## 'old style matrix'
317            if     (isDiagonal  (x)) "d"
318            else if(isTriangular(x)) "t"
319            else if(isSymmetric (x)) "s"
320            else "g" # general
321        }
322        else if(extends(clx, "diagonalMatrix"))  "d"
323        else if(extends(clx, "triangularMatrix"))"t"
324        else if(extends(clx, "symmetricMatrix")) "s"
325        else "g"
326    }
327
328
329  class2 <- function(cl, kind = "l", do.sub = TRUE) {  class2 <- function(cl, kind = "l", do.sub = TRUE) {
330      ## Find "corresponding" class; since pos.def. matrices have no pendant:      ## Find "corresponding" class; since pos.def. matrices have no pendant:
331      if     (cl == "dpoMatrix") paste(kind, "syMatrix", sep='')      if     (cl == "dpoMatrix") paste(kind, "syMatrix", sep='')
# Line 298  Line 337
337  geClass <- function(x) {  geClass <- function(x) {
338      if(is(x, "dMatrix")) "dgeMatrix"      if(is(x, "dMatrix")) "dgeMatrix"
339      else if(is(x, "lMatrix")) "lgeMatrix"      else if(is(x, "lMatrix")) "lgeMatrix"
340        else if(is(x, "zMatrix")) "zgeMatrix"
341      else stop("general Matrix class not yet implemented for ",      else stop("general Matrix class not yet implemented for ",
342                class(x))                class(x))
343  }  }
344
345    .dense.prefixes <- c("d" = "di",
346                         "t" = "tr",
347                         "s" = "sy",
348                         "g" = "ge")
349
350    .Csparse.prefix <- function(ch) {
351        switch(ch,
352               "d" =, "t" = "tC",
353               "s" = "sC",
354               "g" = "gC",
355               stop("invalid Matrix shape: ", ch))
356    }
357
358  ## Used, e.g. after subsetting: Try to use specific class -- if feasible :  ## Used, e.g. after subsetting: Try to use specific class -- if feasible :
359  as_geClass <- function(x, cl) {  as_dense <- function(x) {
360      clx <- class(x)      as(x, paste(.M.kind(x), .dense.prefixes[.M.shape(x)], "Matrix", sep=''))
kind <-
if(is.matrix(x)) { # 'old style matrix'
if(is.numeric(x)) "d" else if(is.logical(x)) "l"
else stop("general Matrix class not implemented for matrix w/ typeof ",
typeof(x))
361          }          }
362          else if(extends(clx, "dMatrix")) "d"
363          else if(extends(clx, "lMatrix")) "l"  as_Csparse <- function(x) {
364        as(x, paste(.M.kind(x), .Csparse.prefix(.M.shape(x)), "Matrix", sep=''))
365    }
366
367    as_geClass <- function(x, cl) {
368        if     (extends(cl, "diagonalMatrix")  && isDiagonal(x))
369            as(x, cl)
370        else if(extends(cl, "symmetricMatrix") &&  isSymmetric(x))
371            as(x, class2(cl, kind, do.sub= kind != "d"))
372        else if(extends(cl, "triangularMatrix") && isTriangular(x))
373            as(x, cl)
374          else          else
375              stop("general Matrix class not yet implemented for ", clx)          as(x, paste(.M.kind(x), "geMatrix", sep=''))
376    }
377
378      clDia <- extends(cl, "diagonalMatrix")  as_CspClass <- function(x, cl) {
379      clSym <- extends(cl, "symmetricMatrix")      if ((extends(cl, "diagonalMatrix")  && isDiagonal(x)) ||
380      clTri <- extends(cl, "triangularMatrix")          (extends(cl, "symmetricMatrix") &&  isSymmetric(x)) ||
381      if     (clDia && .is.diagonal(x)) as(x, cl)          (extends(cl, "triangularMatrix")&& isTriangular(x)))
382      else if(clSym &&  isSymmetric(x)) as(x, class2(cl, kind, do.sub= kind != "d"))          as(x, cl)
383      else if(clTri && isTriangular(x)) as(x, cl)      else as(x, paste(.M.kind(x), "gCMatrix", sep=''))
else as(x, paste(kind, "geMatrix", sep=''))
384  }  }
385
386
387  ## -> ./ddenseMatrix.R :  ## -> ./ddenseMatrix.R :
388  d2l_Matrix <- function(from) {  d2l_Matrix <- function(from) {
389      stopifnot(is(from, "dMatrix"))      stopifnot(is(from, "dMatrix"))

Legend:
 Removed from v.1330 changed lines Added in v.1331

 root@r-forge.r-project.org ViewVC Help Powered by ViewVC 1.0.0
Thanks to: