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 1575, Mon Sep 18 14:47:40 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 121  Line 121 
121      x      x
122  }  }
123    
124    ### TODO:  write in C and port to base (or 'utils') R
125    indTri <- function(n, upper = TRUE) {
126        ## == which(upper.tri(diag(n)) or
127        ##    which(lower.tri(diag(n)) -- but much more efficiently for largish 'n'
128        stopifnot(length(n) == 1, n == (n. <- as.integer(n)), (n <- n.) >= 0)
129        if(n <= 2)
130            return(if(n == 2) as.integer(if(upper) n+1 else n) else integer(0))
131        ## First, compute the 'diff(.)'  fast.  Use integers
132        one <- 1:1 ; two <- 2:2
133        n1 <- n - one
134        n2 <- n1 - one
135        r <- rep.int(one, n*n1/two - one)
136        r[cumsum(if(upper) 1:n2 else c(n1, if(n >= 4) n2:two))] <- if(upper) n:3 else 3:n
137        ## now have "dliu" difference; revert to "liu":
138        cumsum(c(if(upper) n+one else two, r))
139    }
140    
141    
142  prTriang <- function(x, digits = getOption("digits"),  prTriang <- function(x, digits = getOption("digits"),
143                       maxp = getOption("max.print"),                       maxp = getOption("max.print"),
144                       justify = "none", right = TRUE)                       justify = "none", right = TRUE)
# Line 183  Line 201 
201      else                x != 0 & !is.na(x)      else                x != 0 & !is.na(x)
202  }  }
203    
204  ### FIXME? -- make this into a generic function (?)  ## Number of non-zeros :
205    ## FIXME? -- make this into a generic function (?)
206  nnzero <- function(x, na.counted = NA) {  nnzero <- function(x, na.counted = NA) {
207      ## na.counted: TRUE: NA's are counted, they are not 0      ## na.counted: TRUE: NA's are counted, they are not 0
208      ##               NA: NA's are not known (0 or not) ==>  result := NA      ##               NA: NA's are not known (0 or not) ==>  result := NA
# Line 214  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 227  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 300  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 486  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    
# Line 594  Line 623 
623  }  }
624    
625    
626    ## FIXME? -- this should also work for "ltT", "ntT", ... :
627  diagU2N <- function(x)  diagU2N <- function(x)
628  {  {
629      ## Purpose: Transform a *unit diagonal* triangular matrix      ## Purpose: Transform a *unit diagonal* sparse triangular matrix
630      ##  into one with explicit diagonal entries '1'      ##  into one with explicit diagonal entries '1'
631      xT <- as(x, "dgTMatrix")      xT <- as(x, "dgTMatrix")
632      ## leave it as  T* - the caller can always coerce to C* if needed:      ## leave it as  T* - the caller can always coerce to C* if needed:

Legend:
Removed from v.1575  
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