SCM

SCM Repository

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

Diff of /pkg/R/Auxiliaries.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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:
Vienna University of Economics and Business Powered By FusionForge