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 1592, Thu Sep 28 15:31:17 2006 UTC revision 1654, Fri Oct 27 16:58:15 2006 UTC
# Line 22  Line 22 
22      function(x) !identical(list(NULL,NULL), x@Dimnames)      function(x) !identical(list(NULL,NULL), x@Dimnames)
23    
24  .bail.out.1 <- function(fun, cl) {  .bail.out.1 <- function(fun, cl) {
25      stop(gettextf('not-yet-implemented method for %s(<%s>)', fun, cl),      stop(gettextf('not-yet-implemented method for %s(<%s>).\n ->>  Ask the package authors to implement the missing feature.', fun, cl),
26           call. = FALSE)           call. = FALSE)
27  }  }
28  .bail.out.2 <- function(fun, cl1, cl2) {  .bail.out.2 <- function(fun, cl1, cl2) {
29      stop(gettextf('not-yet-implemented method for %s(<%s>, <%s>)',      stop(gettextf('not-yet-implemented method for %s(<%s>, <%s>).\n ->>  Ask the package authors to implement the missing feature.',
30                    fun, cl1, cl2), call. = FALSE)                    fun, cl1, cl2), call. = FALSE)
31  }  }
32    
# Line 233  Line 233 
233          if(is(M, "TsparseMatrix"))          if(is(M, "TsparseMatrix"))
234              return(unique(cbind(M@i,M@j)))              return(unique(cbind(M@i,M@j)))
235          if(is(M, "pMatrix"))          if(is(M, "pMatrix"))
236              return(cbind(seq(length=nrow(M)), M@perm) - 1:1)              return(cbind(seq_len(nrow(M)), M@perm) - 1:1)
237          ## else:          ## else:
238          isC <- any("i" == slotNames(M)) # is Csparse (not Rsparse)          isC <- any("i" == slotNames(M)) # is Csparse (not Rsparse)
239          .Call(compressed_non_0_ij, M, isC)          .Call(compressed_non_0_ij, M, isC)
# Line 246  Line 246 
246      }      }
247      else if(is(x, "triangularMatrix")) { # check for "U" diag      else if(is(x, "triangularMatrix")) { # check for "U" diag
248          if(x@diag == "U") {          if(x@diag == "U") {
249              i <- seq(length = dim(x)[1]) - 1:1              i <- seq_len(dim(x)[1]) - 1:1
250              rbind(non0.i(x), cbind(i,i))              rbind(non0.i(x), cbind(i,i))
251          } else non0.i(x)          } else non0.i(x)
252      }      }
# Line 319  Line 319 
319  ## would be slightly more efficient than as( <dgC> , "dgTMatrix")  ## would be slightly more efficient than as( <dgC> , "dgTMatrix")
320  ## but really efficient would be to use only one .Call(.) for uniq(.) !  ## but really efficient would be to use only one .Call(.) for uniq(.) !
321    
322    drop0 <- function(x, clx = c(class(x))) {
323        ## FIXME: Csparse_drop should do this (not losing symm./triang.):
324        ## Careful: 'Csparse_drop' also drops triangularity,...
325        ## .Call(Csparse_drop, as_CspClass(x, clx), 0)
326        as_CspClass(.Call(Csparse_drop, as_CspClass(x, clx), 0.),
327                    clx)
328    }
329    
330  uniq <- function(x) {  uniq <- function(x) {
331      if(is(x, "TsparseMatrix")) uniqTsparse(x) else x      if(is(x, "TsparseMatrix")) uniqTsparse(x) else
332      ## else:  not 'Tsparse', i.e. "uniquely" represented in any case      if(is(x, "sparseMatrix")) drop0(x) else x
333  }  }
334    
335  asTuniq <- function(x) {  asTuniq <- function(x) {
# Line 505  Line 513 
513  }  }
514    
515  as_CspClass <- function(x, cl) {  as_CspClass <- function(x, cl) {
516      if ((extends(cl, "diagonalMatrix")  && isDiagonal(x)) ||      if (## diagonal is *not* sparse:
517            ##(extends(cl, "diagonalMatrix") && isDiagonal(x)) ||
518          (extends(cl, "symmetricMatrix") &&  isSymmetric(x)) ||          (extends(cl, "symmetricMatrix") &&  isSymmetric(x)) ||
519          (extends(cl, "triangularMatrix")&& isTriangular(x)))          (extends(cl, "triangularMatrix")&& isTriangular(x)))
520          as(x, cl)          as(x, cl)
521        else if(is(x, "CsparseMatrix")) x
522      else as(x, paste(.M.kind(x), "gCMatrix", sep=''))      else as(x, paste(.M.kind(x), "gCMatrix", sep=''))
523  }  }
524    

Legend:
Removed from v.1592  
changed lines
  Added in v.1654

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