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 1198, Mon Jan 23 15:01:02 2006 UTC revision 1575, Mon Sep 18 14:47:40 2006 UTC
# Line 1  Line 1 
1  #### "Namespace private" Auxiliaries  such as method functions  #### "Namespace private" Auxiliaries  such as method functions
2  #### (called from more than one place --> need to be defined early)  #### (called from more than one place --> need to be defined early)
3    
4    .isR_24 <- (paste(R.version$major, R.version$minor, sep=".") >= "2.4")
5    
6    ## Need to consider NAs ;  "== 0" even works for logical & complex:
7    is0  <- function(x) !is.na(x) & x == 0
8    isN0 <- function(x)  is.na(x) | x != 0
9    all0 <- function(x) !any(is.na(x)) && all(x == 0)
10    
11    allTrue  <- function(x) !any(is.na(x)) && all(x)
12    allFalse <- function(x) !any(is.na(x)) && !any(x)
13    
14    
15  ## For %*% (M = Matrix; v = vector (double or integer {complex maybe?}):  ## For %*% (M = Matrix; v = vector (double or integer {complex maybe?}):
16  .M.v <- function(x, y) callGeneric(x, as.matrix(y))  .M.v <- function(x, y) callGeneric(x, as.matrix(y))
17  .v.M <- function(x, y) callGeneric(rbind(x), y)  .v.M <- function(x, y) callGeneric(rbind(x), y)
18    
19    .M.DN <- function(x) if(!is.null(dn <- dimnames(x))) dn else list(NULL,NULL)
20    
21  .has.DN <- ## has non-trivial Dimnames slot?  .has.DN <- ## has non-trivial Dimnames slot?
22      function(x) !identical(list(NULL,NULL), x@Dimnames)      function(x) !identical(list(NULL,NULL), x@Dimnames)
23    
# Line 17  Line 30 
30                    fun, cl1, cl2), call. = FALSE)                    fun, cl1, cl2), call. = FALSE)
31  }  }
32    
33    ## This should be done in C and be exported by 'methods':  [FIXME - ask JMC ]
34    copyClass <- function(x, newCl, sNames =
35                          intersect(slotNames(newCl), slotNames(x))) {
36        r <- new(newCl)
37        for(n in sNames)
38            slot(r, n) <- slot(x, n)
39        r
40    }
41    
42  ## chol() via "dpoMatrix"  ## chol() via "dpoMatrix"
43  cholMat <- function(x, pivot, LINPACK) {  cholMat <- function(x, pivot, ...) {
44      px <- as(x, "dpoMatrix")      px <- as(x, "dpoMatrix")
45      if (isTRUE(validObject(px, test=TRUE))) chol(px)      if (isTRUE(validObject(px, test=TRUE))) chol(px)
46      else stop("'x' is not positive definite -- chol() undefined.")      else stop("'x' is not positive definite -- chol() undefined.")
# Line 82  Line 104 
104      da[2]      da[2]
105  }  }
106    
107    ## Note: !isPacked(.)  i.e. `full' still contains
108    ## ----  "*sy" and "*tr" which have "undefined" lower or upper part
109    isPacked <- function(x)
110    {
111        ## Is 'x' a packed (dense) matrix ?
112        is(x, "denseMatrix") &&
113        any("x" == slotNames(x)) && length(x@x) < prod(dim(x))
114    }
115    
116  emptyColnames <- function(x)  emptyColnames <- function(x)
117  {  {
118      ## Useful for compact printing of (parts) of sparse matrices      ## Useful for compact printing of (parts) of sparse matrices
# Line 91  Line 122 
122  }  }
123    
124  prTriang <- function(x, digits = getOption("digits"),  prTriang <- function(x, digits = getOption("digits"),
125                         maxp = getOption("max.print"),
126                       justify = "none", right = TRUE)                       justify = "none", right = TRUE)
127  {  {
128      ## modeled along stats:::print.dist      ## modeled along stats:::print.dist
     diag <- TRUE  
129      upper <- x@uplo == "U"      upper <- x@uplo == "U"
130    
131      m <- as(x, "matrix")      m <- as(x, "matrix")
# Line 103  Line 134 
134          cf[row(cf) > col(cf)] <- "."          cf[row(cf) > col(cf)] <- "."
135      else      else
136          cf[row(cf) < col(cf)] <- "."          cf[row(cf) < col(cf)] <- "."
137      print(cf, quote = FALSE, right = right)      if(.isR_24)
138             print(cf, quote = FALSE, right = right, max = maxp)
139        else print(cf, quote = FALSE, right = right)
140      invisible(x)      invisible(x)
141  }  }
142    
143  prMatrix <- function(x, digits = getOption("digits")) {  prMatrix <- function(x, digits = getOption("digits"),
144                         maxp = getOption("max.print")) {
145      d <- dim(x)      d <- dim(x)
146      cl <- class(x)      cl <- class(x)
147      cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))      cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
     maxp <- getOption("max.print")  
148      if(prod(d) <= maxp) {      if(prod(d) <= maxp) {
149          if(is(x, "triangularMatrix"))          if(is(x, "triangularMatrix"))
150              prTriang(x, digits = digits)              prTriang(x, digits = digits, maxp = maxp)
151          else          else {
152              print(as(x, "matrix"), digits = digits)              if(.isR_24)
153                     print(as(x, "matrix"), digits = digits, max = maxp)
154                else print(as(x, "matrix"), digits = digits)
155            }
156      }      }
157      else { ## d[1] > maxp / d[2] >= nr :      else { ## d[1] > maxp / d[2] >= nr :
158          m <- as(x, "matrix")          m <- as(x, "matrix")
# Line 130  Line 166 
166      invisible(x)# as print() S3 methods do      invisible(x)# as print() S3 methods do
167  }  }
168    
169    nonFALSE <- function(x) {
170        ## typically used for lMatrices:  (TRUE,NA,FALSE) |-> (TRUE,FALSE)
171        if(any(ix <- is.na(x))) x[ix] <- TRUE
172        x
173    }
174    
175    nz.NA <- function(x, na.value) {
176        ## Non-Zeros of x
177        ## na.value: TRUE: NA's give TRUE, they are not 0
178        ##             NA: NA's are not known ==> result := NA
179        ##          FALSE: NA's give FALSE, could be 0
180        stopifnot(is.logical(na.value) && length(na.value) == 1)
181        if(is.na(na.value)) x != 0
182        else  if(na.value)  isN0(x)
183        else                x != 0 & !is.na(x)
184    }
185    
186    ### FIXME? -- make this into a generic function (?)
187    nnzero <- function(x, na.counted = NA) {
188        ## na.counted: TRUE: NA's are counted, they are not 0
189        ##               NA: NA's are not known (0 or not) ==>  result := NA
190        ##            FALSE: NA's are omitted before counting
191        cl <- class(x)
192        if(!extends(cl, "Matrix"))
193            sum(nz.NA(x, na.counted))
194        else if(extends(cl, "sparseMatrix"))
195            ## NOTA BENE: The number of *structural* non-zeros {could have other '0'}!
196           switch(.sp.class(cl),
197                   "CsparseMatrix" = length(x@i),
198                   "TsparseMatrix" = length(x@i),
199                   "RsparseMatrix" = length(x@j))
200        else ## denseMatrix
201            sum(nz.NA(as_geClass(x, cl)@x, na.counted))
202    }
203    
204  ## For sparseness handling  ## For sparseness handling
205    ## return a 2-column (i,j) matrix of
206    ## 0-based indices of non-zero entries  :
207  non0ind <- function(x) {  non0ind <- function(x) {
     if(is.numeric(x))  
         return(if((n <- length(x))) (0:(n-1))[x != 0] else integer(0))  
   
     ## else return a (i,j) matrix of non-zero-indices  
208    
209        if(is.numeric(x))
210            return(if((n <- length(x))) (0:(n-1))[isN0(x)] else integer(0))
211        ## else
212      stopifnot(is(x, "sparseMatrix"))      stopifnot(is(x, "sparseMatrix"))
213      if(is(x, "TsparseMatrix"))      non0.i <- function(M) {
214          return(unique(cbind(x@i,x@j)))          if(is(M, "TsparseMatrix"))
215                return(unique(cbind(M@i,M@j)))
216            if(is(M, "pMatrix"))
217                return(cbind(seq(length=nrow(M)), M@perm) - 1:1)
218            ## else:
219            isC <- any("i" == slotNames(M)) # is Csparse (not Rsparse)
220            .Call(compressed_non_0_ij, M, isC)
221        }
222    
223        if(is(x, "symmetricMatrix")) { # also get "other" triangle
224            ij <- non0.i(x)
225            notdiag <- ij[,1] != ij[,2]# but not the diagonals again
226            rbind(ij, ij[notdiag, 2:1])
227        }
228        else if(is(x, "triangularMatrix")) { # check for "U" diag
229            if(x@diag == "U") {
230                i <- seq(length = dim(x)[1]) - 1:1
231                rbind(non0.i(x), cbind(i,i))
232            } else non0.i(x)
233        }
234        else
235            non0.i(x)
236    }
237    
238    ## nr= nrow: since  i in {0,1,.., nrow-1}  these are 1:1 "decimal" encodings:
239    ## Further, these map to and from the usual "Fortran-indexing" (but 0-based)
240    encodeInd <- function(ij, nr) ij[,1] + ij[,2] * nr
241    decodeInd <- function(code, nr) cbind(code %% nr, code %/% nr)
242    
243      isCol <- function(M) any("i" == slotNames(M))  complementInd <- function(ij, dim)
244      .Call("compressed_non_0_ij", x, isCol(x), PACKAGE = "Matrix")  {
245        ## Purpose: Compute the complement of the 2-column 0-based ij-matrix
246        ##          but as 1-based indices
247        n <- prod(dim)
248        if(n == 0) return(integer(0))
249        ii <- 1:n
250        ii[-(1 + encodeInd(ij, nr = dim[1]))]
251    }
252    
253    unionInd <- function(ij1, ij2) unique(rbind(ij1, ij2))
254    
255    intersectInd <- function(ij1, ij2, nrow) {
256        ## from 2-column (i,j) matrices where i in {0,.., nrow-1},
257        ## return only the *common* entries
258        decodeInd(intersect(encodeInd(ij1, nrow),
259                            encodeInd(ij2, nrow)), nrow)
260    }
261    
262    WhichintersectInd <- function(ij1, ij2, nrow) {
263        ## from 2-column (i,j) matrices where i \in {0,.., nrow-1},
264        ## find *where*  common entries are in ij1 & ij2
265        m1 <- match(encodeInd(ij1, nrow), encodeInd(ij2, nrow))
266        ni <- !is.na(m1)
267        list(which(ni), m1[ni])
268  }  }
269    
270    
271  ### There is a test on this in ../tests/dgTMatrix.R !  ### There is a test on this in ../tests/dgTMatrix.R !
272  uniq <- function(x) {  
273      if(is(x, "TsparseMatrix")) {  uniqTsparse <- function(x, class.x = c(class(x))) {
274          ## Purpose: produce a *unique* triplet representation:          ## Purpose: produce a *unique* triplet representation:
275          ##              by having (i,j) sorted and unique          ##              by having (i,j) sorted and unique
276          ## -----------------------------------------------------------          ## -----------------------------------------------------------
277          ## The following is *not* efficient {but easy to program}:      ## The following is not quite efficient {but easy to program,
278          if(is(x, "dgTMatrix")) as(as(x, "dgCMatrix"), "dgTMatrix")      ## and as() are based on C code  (all of them?)
279          else if(is(x, "lgTMatrix")) as(as(x, "lgCMatrix"), "lgTMatrix")      ##
280          else stop("not implemented for class", class(x))      ## FIXME: Do it fast for the case where 'x' is already 'uniq'
281    
282        switch(class.x,
283               "dgTMatrix" = as(as(x, "dgCMatrix"), "dgTMatrix"),
284               "dsTMatrix" = as(as(x, "dsCMatrix"), "dsTMatrix"),
285               "dtTMatrix" = as(as(x, "dtCMatrix"), "dtTMatrix"),
286               ## do we need this for "logical" ones, there's no sum() there!
287               "lgTMatrix" = as(as(x, "lgCMatrix"), "lgTMatrix"),
288               "lsTMatrix" = as(as(x, "lsCMatrix"), "lsTMatrix"),
289               "ltTMatrix" = as(as(x, "ltCMatrix"), "ltTMatrix"),
290               ## do we need this for "logical" ones, there's no sum() there!
291               "ngTMatrix" = as(as(x, "ngCMatrix"), "ngTMatrix"),
292               "nsTMatrix" = as(as(x, "nsCMatrix"), "nsTMatrix"),
293               "ntTMatrix" = as(as(x, "ntCMatrix"), "ntTMatrix"),
294               ## otherwise:
295               stop("not yet implemented for class ", class.x))
296    }
297    
298    ## Note: maybe, using
299    ## ----    xj <- .Call(Matrix_expand_pointers, x@p)
300    ## would be slightly more efficient than as( <dgC> , "dgTMatrix")
301    ## but really efficient would be to use only one .Call(.) for uniq(.) !
302    
303    uniq <- function(x) {
304        if(is(x, "TsparseMatrix")) uniqTsparse(x) else x
305        ## else:  not 'Tsparse', i.e. "uniquely" represented in any case
306    }
307    
308      } else x      # not 'gT' ; i.e. "uniquely" represented in any case  asTuniq <- function(x) {
309        if(is(x, "TsparseMatrix")) uniqTsparse(x) else as(x,"TsparseMatrix")
310  }  }
311    
312  if(FALSE) ## try an "efficient" version  if(FALSE) ## try an "efficient" version
# Line 164  Line 314 
314  {  {
315      ## Purpose: produce a *unique* triplet representation:      ## Purpose: produce a *unique* triplet representation:
316      ##          by having (i,j) sorted and unique      ##          by having (i,j) sorted and unique
317      ## ----------------------------------------------------------------------      ## ------------------------------------------------------------------
318      ## Arguments: a "gT" Matrix      ## Arguments: a "gT" Matrix
319      stopifnot(is(x, "gTMatrix"))      stopifnot(is(x, "gTMatrix"))
320      if((n <- length(x@i)) == 0) return(x)      if((n <- length(x@i)) == 0) return(x)
# Line 220  Line 370 
370      ## FIXME: treat 'factors' smartly {not for triangular!}      ## FIXME: treat 'factors' smartly {not for triangular!}
371  }  }
372    
373    ## -> ./ndenseMatrix.R :
374    n2d_Matrix <- function(from) {
375        stopifnot(is(from, "nMatrix"))
376        fixupDense(new(sub("^n", "d", class(from)),
377                       x = as.double(from@x),
378                       Dim = from@Dim, Dimnames = from@Dimnames),
379                   from)
380        ## FIXME: treat 'factors' smartly {not for triangular!}
381    }
382    n2l_spMatrix <- function(from) {
383        stopifnot(is(from, "nMatrix"))
384        new(sub("^n", "l", class(from)),
385            ##x = as.double(from@x),
386            Dim = from@Dim, Dimnames = from@Dimnames)
387    }
388    
389  if(FALSE)# unused  if(FALSE)# unused
390  l2d_meth <- function(x) {  l2d_meth <- function(x) {
391      cl <- class(x)      cl <- class(x)
392      as(callGeneric(as(x, sub("^l", "d", cl))), cl)      as(callGeneric(as(x, sub("^l", "d", cl))), cl)
393  }  }
394    
395    ## return "d" or "l" or "n" or "z"
396    .M.kind <- function(x, clx = class(x)) {
397        if(is.matrix(x)) { ## 'old style matrix'
398            if     (is.numeric(x)) "d"
399            else if(is.logical(x)) "l" ## FIXME ? "n" if no NA ??
400            else if(is.complex(x)) "z"
401            else stop("not yet implemented for matrix w/ typeof ", typeof(x))
402        }
403        else if(extends(clx, "dMatrix")) "d"
404        else if(extends(clx, "nMatrix")) "n"
405        else if(extends(clx, "lMatrix")) "l"
406        else if(extends(clx, "zMatrix")) "z"
407        else if(extends(clx, "pMatrix")) "n" # permutation -> pattern
408        else stop(" not yet be implemented for ", clx)
409    }
410    
411    .M.shape <- function(x, clx = class(x)) {
412        if(is.matrix(x)) { ## 'old style matrix'
413            if     (isDiagonal  (x)) "d"
414            else if(isTriangular(x)) "t"
415            else if(isSymmetric (x)) "s"
416            else "g" # general
417        }
418        else if(extends(clx, "diagonalMatrix"))  "d"
419        else if(extends(clx, "triangularMatrix"))"t"
420        else if(extends(clx, "symmetricMatrix")) "s"
421        else "g"
422    }
423    
424    
425    class2 <- function(cl, kind = "l", do.sub = TRUE) {
426        ## Find "corresponding" class; since pos.def. matrices have no pendant:
427        if     (cl == "dpoMatrix") paste(kind, "syMatrix", sep='')
428        else if(cl == "dppMatrix") paste(kind, "spMatrix", sep='')
429        else if(do.sub) sub("^d", kind, cl)
430        else cl
431    }
432    
433    geClass <- function(x) {
434        if     (is(x, "dMatrix")) "dgeMatrix"
435        else if(is(x, "lMatrix")) "lgeMatrix"
436        else if(is(x, "nMatrix")) "ngeMatrix"
437        else if(is(x, "zMatrix")) "zgeMatrix"
438        else stop("general Matrix class not yet implemented for ",
439                  class(x))
440    }
441    
442    .dense.prefixes <- c("d" = "di",
443                         "t" = "tr",
444                         "s" = "sy",
445                         "g" = "ge")
446    
447    .sparse.prefixes <- c("d" = "t", ## map diagonal to triangular
448                          "t" = "t",
449                          "s" = "s",
450                          "g" = "g")
451    
452    ## Used, e.g. after subsetting: Try to use specific class -- if feasible :
453    as_dense <- function(x) {
454        as(x, paste(.M.kind(x), .dense.prefixes[.M.shape(x)], "Matrix", sep=''))
455    }
456    
457    .sp.class <- function(x) { ## find and return the "sparseness class"
458        if(!is.character(x)) x <- class(x)
459        for(cl in paste(c("C","T","R"), "sparseMatrix", sep=''))
460            if(extends(x, cl))
461                return(cl)
462        ## else (should rarely happen)
463        as.character(NA)
464    }
465    
466    as_Csparse <- function(x) {
467        as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "CMatrix", sep=''))
468    }
469    as_Rsparse <- function(x) {
470        as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "RMatrix", sep=''))
471    }
472    as_Tsparse <- function(x) {
473        as(x, paste(.M.kind(x), .sparse.prefixes[.M.shape(x)], "TMatrix", sep=''))
474    }
475    
476    as_geClass <- function(x, cl) {
477        if     (extends(cl, "diagonalMatrix")  && isDiagonal(x))
478            as(x, cl)
479        else if(extends(cl, "symmetricMatrix") &&  isSymmetric(x)) {
480            kind <- .M.kind(x)
481            as(x, class2(cl, kind, do.sub= kind != "d"))
482        } else if(extends(cl, "triangularMatrix") && isTriangular(x))
483            as(x, cl)
484        else
485            as(x, paste(.M.kind(x), "geMatrix", sep=''))
486    }
487    
488    as_CspClass <- function(x, cl) {
489        if ((extends(cl, "diagonalMatrix")  && isDiagonal(x)) ||
490            (extends(cl, "symmetricMatrix") &&  isSymmetric(x)) ||
491            (extends(cl, "triangularMatrix")&& isTriangular(x)))
492            as(x, cl)
493        else as(x, paste(.M.kind(x), "gCMatrix", sep=''))
494    }
495    
496    
497  ## -> ./ddenseMatrix.R :  ## -> ./ddenseMatrix.R :
498  d2l_Matrix <- function(from) {  d2l_Matrix <- function(from) {
499      stopifnot(is(from, "dMatrix"))      stopifnot(is(from, "dMatrix"))
500      fixupDense(new(sub("^d", "l", class(from)),      fixupDense(new(sub("^d", "l", class(from)), # no need for dClass2 here
501                     Dim = from@Dim, Dimnames = from@Dimnames),                     Dim = from@Dim, Dimnames = from@Dimnames),
502                 from)                 from)
503      ## FIXME: treat 'factors' smartly {not for triangular!}      ## FIXME: treat 'factors' smartly {not for triangular!}
# Line 247  Line 515 
515      if(ok) as(x, classes[1]) else x      if(ok) as(x, classes[1]) else x
516  }  }
517    
 if(paste(R.version$major, R.version$minor, sep=".") < "2.3")  
     ## This will be in R 2.3.0  
 canCoerce <- function(object, Class) {  
   ## Purpose:  test if 'object' is coercable to 'Class', i.e.,  
   ##           as(object, Class) will {typically} work  
   ## ----------------------------------------------------------------------  
   ## Author: John Chambers, Date:  6 Oct 2005  
    is(object, Class) ||  
    !is.null(selectMethod("coerce", c(class(object), Class),  
                          optional = TRUE,  
                          useInherited = c(from = TRUE, to = FALSE)))  
 }  
518    
519  .is.triangular <- function(object, upper = TRUE) {  ## For *dense* matrices
520    isTriMat <- function(object, upper = NA) {
521      ## pretest: is it square?      ## pretest: is it square?
522      d <- dim(object)      d <- dim(object)
523      if(d[1] != d[2]) return(FALSE)      if(d[1] != d[2]) return(FALSE)
524      ## else slower test      ## else slower test
525      if(!is.matrix(object))      if(!is.matrix(object))
526          object <- as(object,"matrix")          object <- as(object,"matrix")
527      ## == 0 even works for logical & complex:      if(is.na(upper)) {
528      if(upper)          if(all0(object[lower.tri(object)]))
529          all(object[lower.tri(object)] == 0)              structure(TRUE, kind = "U")
530      else          else if(all0(object[upper.tri(object)]))
531          all(object[upper.tri(object)] == 0)              structure(TRUE, kind = "L")
532            else FALSE
533        } else if(upper)
534            all0(object[lower.tri(object)])
535        else ## upper is FALSE
536            all0(object[upper.tri(object)])
537    }
538    
539    ## For Csparse matrices
540    isTriC <- function(x, upper = NA) {
541        ## pretest: is it square?
542        d <- dim(x)
543        if(d[1] != d[2]) return(FALSE)
544        ## else
545        if(d[1] == 0) return(TRUE)
546        ni <- 1:d[2]
547        ## the row indices split according to column:
548        ilist <- split(x@i, factor(rep.int(ni, diff(x@p)), levels= ni))
549        lil <- unlist(lapply(ilist, length), use.names = FALSE)
550        if(any(lil == 0)) {
551            pos <- lil > 0
552            if(!any(pos)) ## matrix of all 0's
553                return(TRUE)
554            ilist <- ilist[pos]
555            ni <- ni[pos]
556        }
557        ni0 <- ni - 1:1 # '0-based ni'
558        if(is.na(upper)) {
559            if(all(sapply(ilist, max, USE.NAMES = FALSE) <= ni0))
560                structure(TRUE, kind = "U")
561            else if(all(sapply(ilist, min, USE.NAMES = FALSE) >= ni0))
562                structure(TRUE, kind = "L")
563            else FALSE
564        } else if(upper) {
565            all(sapply(ilist, max, USE.NAMES = FALSE) <= ni0)
566        } else { ## 'lower'
567            all(sapply(ilist, min, USE.NAMES = FALSE) >= ni0)
568        }
569  }  }
570    
571  .is.diagonal <- function(object) {  .is.diagonal <- function(object) {
572        ## "matrix" or "denseMatrix" (but not "diagonalMatrix")
573      d <- dim(object)      d <- dim(object)
574      if(d[1] != (n <- d[2])) FALSE      if(d[1] != (n <- d[2])) FALSE
575      else all(object[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)] == 0)      else if(is.matrix(object))
576            ## requires that "vector-indexing" works for 'object' :
577            all0(object[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)])
578        else ## "denseMatrix" -- packed or unpacked
579            if(is(object, "generalMatrix")) # "dge", "lge", ...
580                all0(object@x[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)])
581            else { ## "dense" but not {diag, general}, i.e. triangular or symmetric:
582                ## -> has 'uplo'  differentiate between packed and unpacked
583    
584    ### .......... FIXME ...............
585    
586                packed <- isPacked(object)
587                if(object@uplo == "U") {
588                } else { ## uplo == "L"
589                }
590    
591    ### very cheap workaround
592                all0(as.matrix(object)[rep(c(FALSE, rep.int(TRUE,n)), length = n^2)])
593            }
594    }
595    
596    
597    diagU2N <- function(x)
598    {
599        ## Purpose: Transform a *unit diagonal* triangular matrix
600        ##  into one with explicit diagonal entries '1'
601        xT <- as(x, "dgTMatrix")
602        ## leave it as  T* - the caller can always coerce to C* if needed:
603        new("dtTMatrix", x = xT@x, i = xT@i, j = xT@j, Dim = x@Dim,
604            Dimnames = x@Dimnames, uplo = x@uplo, diag = "N")
605  }  }
606    
607    ## FIXME: this should probably be dropped / replaced by as_Csparse
608    .as.dgC.Fun <- function(x, na.rm = FALSE, dims = 1) {
609        x <- as(x, "dgCMatrix")
610        callGeneric()
611    }
612    
613    .as.dgT.Fun <- function(x, na.rm = FALSE, dims = 1) {
614        ## used e.g. inside colSums() etc methods
615        x <- as(x, "dgTMatrix")
616        callGeneric()
617    }
618    
619    
620    ### Fast much simplified version of tapply()
621    tapply1 <- function (X, INDEX, FUN = NULL, ..., simplify = TRUE) {
622        sapply(split(X, INDEX), FUN, ..., simplify = simplify, USE.NAMES = FALSE)
623    }
624    
625    ## tapply.x <- function (X, n, INDEX, FUN = NULL, ..., simplify = TRUE) {
626    ##     tapply1(X, factor(INDEX, 0:(n-1)), FUN = FUN, ..., simplify = simplify)
627    ## }
628    

Legend:
Removed from v.1198  
changed lines
  Added in v.1575

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