SCM

SCM Repository

[matrix] Diff of /pkg/Matrix/R/diagMatrix.R
ViewVC logotype

Diff of /pkg/Matrix/R/diagMatrix.R

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

revision 1682, Fri Dec 1 18:42:40 2006 UTC revision 2096, Fri Dec 7 17:44:44 2007 UTC
# Line 43  Line 43 
43      ## make sure we had all matrices:      ## make sure we had all matrices:
44      if(!(is.matrix(dims) && nrow(dims) == 2))      if(!(is.matrix(dims) && nrow(dims) == 2))
45          stop("some arguments are not matrices")          stop("some arguments are not matrices")
46      csdim <- rbind(rep.int(0:0, 2),      csdim <- rbind(rep.int(0L, 2),
47                     apply(sapply(mlist, dim), 1, cumsum))                     apply(sapply(mlist, dim), 1, cumsum))
48      ret <- new("dgTMatrix", Dim = as.integer(csdim[nrow(csdim),]))      ret <- new("dgTMatrix", Dim = as.integer(csdim[nrow(csdim),]))
49      add1 <- matrix(1:0, 2,2)      add1 <- matrix(1:0, 2,2)
# Line 58  Line 58 
58      as(ret, "CsparseMatrix")      as(ret, "CsparseMatrix")
59  }  }
60    
61  diag2T <- function(from) {  diag2tT <- function(from) {
62      i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1:1      i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
63      new(paste(.M.kind(from), "tTMatrix", sep=''),      new(paste(.M.kind(from), "tTMatrix", sep=''),
64          diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,          diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,
65          x = from@x, # <- ok for diag = "U" and "N" (!)          x = from@x, # <- ok for diag = "U" and "N" (!)
66          i = i, j = i)          i = i, j = i)
67  }  }
68    
69  setAs("diagonalMatrix", "triangularMatrix", diag2T)  diag2sT <- function(from) { # to symmetric Tsparse
70  setAs("diagonalMatrix", "sparseMatrix", diag2T)      i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
71        new(paste(.M.kind(from), "sTMatrix", sep=''),
72            Dim = from@Dim, Dimnames = from@Dimnames,
73            x = from@x, i = i, j = i)
74    }
75    
76    setAs("diagonalMatrix", "triangularMatrix", diag2tT)
77    setAs("diagonalMatrix", "sparseMatrix", diag2tT)
78    ## needed too (otherwise <dense> -> Tsparse is taken):
79    setAs("diagonalMatrix", "TsparseMatrix", diag2tT)
80  ## is better than this:  ## is better than this:
81  ## setAs("diagonalMatrix", "sparseMatrix",  ## setAs("diagonalMatrix", "sparseMatrix",
82  ##       function(from)  ##       function(from)
83  ##        as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))  ##        as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
84  setAs("diagonalMatrix", "CsparseMatrix",  setAs("diagonalMatrix", "CsparseMatrix",
85        function(from) as(diag2T(from), "CsparseMatrix"))        function(from) as(diag2tT(from), "CsparseMatrix"))
86    
87    setAs("diagonalMatrix", "symmetricMatrix", diag2sT)
88    
89  setAs("diagonalMatrix", "matrix",  setAs("diagonalMatrix", "matrix",
90        function(from) {        function(from) {
# Line 104  Line 115 
115        function(from) {        function(from) {
116            .Deprecated("as(, \"sparseMatrix\")")            .Deprecated("as(, \"sparseMatrix\")")
117            n <- from@Dim[1]            n <- from@Dim[1]
118            i <- seq_len(n) - 1:1            i <- seq_len(n) - 1L
119            new("dgTMatrix", i = i, j = i, x = .diag.x(from),            new("dgTMatrix", i = i, j = i, x = .diag.x(from),
120                Dim = c(n,n), Dimnames = from@Dimnames) })                Dim = c(n,n), Dimnames = from@Dimnames) })
121    
# Line 117  Line 128 
128            n <- from@Dim[1]            n <- from@Dim[1]
129            if(from@diag == "U") { # unit-diagonal            if(from@diag == "U") { # unit-diagonal
130                x <- rep.int(TRUE, n)                x <- rep.int(TRUE, n)
131                i <- seq_len(n) - 1:1                i <- seq_len(n) - 1L
132            } else { # "normal"            } else { # "normal"
133                nz <- nz.NA(from@x, na. = TRUE)                nz <- nz.NA(from@x, na. = TRUE)
134                x <- from@x[nz]                x <- from@x[nz]
135                i <- which(nz) - 1:1                i <- which(nz) - 1L
136            }            }
137            new("lgTMatrix", i = i, j = i, x = x,            new("lgTMatrix", i = i, j = i, x = x,
138                Dim = c(n,n), Dimnames = from@Dimnames) })                Dim = c(n,n), Dimnames = from@Dimnames) })
# Line 173  Line 184 
184                x = if(uni) x[FALSE] else x)                x = if(uni) x[FALSE] else x)
185        })        })
186    
187    
188    setMethod("diag", signature(x = "diagonalMatrix"),
189              function(x = 1, nrow, ncol) .diag.x(x))
190    
191    
192    subDiag <- function(x, i, j, drop) {
193        x <- as(x, "sparseMatrix")
194        x <- if(missing(i))
195            x[, j, drop=drop]
196        else if(missing(j))
197            x[i, , drop=drop]
198        else
199            x[i,j, drop=drop]
200        if(isDiagonal(x)) as(x, "diagonalMatrix") else x
201    }
202    
203    setMethod("[", signature(x = "diagonalMatrix", i = "index",
204                             j = "index", drop = "logical"), subDiag)
205    setMethod("[", signature(x = "diagonalMatrix", i = "index",
206                            j = "missing", drop = "logical"),
207              function(x, i, drop) subDiag(x, i=i, drop=drop))
208    setMethod("[", signature(x = "diagonalMatrix", i = "missing",
209                             j = "index", drop = "logical"),
210              function(x, j, drop) subDiag(x, j=j, drop=drop))
211    
212  ## When you assign to a diagonalMatrix, the result should be  ## When you assign to a diagonalMatrix, the result should be
213  ## diagonal or sparse  ## diagonal or sparse ---
214  setReplaceMethod("[", signature(x = "diagonalMatrix",  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
215                                  i = "ANY", j = "ANY", value = "ANY"),  replDiag <- function(x, i, j, value) {
216                   function(x, i, j, value) {      x <- as(x, "sparseMatrix")
217                       r <- callGeneric(x = as(x,"sparseMatrix"),      message(sprintf("diagnosing replDiag() -- nargs() = %d\n", nargs()))
218                                        i=i, j=j, value=value)      if(missing(i))
219                       if(isDiagonal(r)) as(r, "diagonalMatrix") else r          x[, j] <- value
220        else if(missing(j))
221            x[i, ] <- value
222        else
223            x[i,j] <- value
224        if(isDiagonal(x)) as(x, "diagonalMatrix") else x
225    }
226    
227    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
228                                    j = "index", value = "replValue"), replDiag)
229    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
230                                    j = "missing", value = "replValue"),
231                     function(x, i, value) replDiag(x, i=i, value=value))
232    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "matrix", # 2-col.matrix
233                                    j = "missing", value = "replValue"),
234                     function(x, i, value) {
235                         if(ncol(i) == 2) {
236                             if(all((ii <- i[,1]) == i[,2])) { # replace in diagonal only
237                                 x@x[ii] <- value
238                                 x
239                             } else { ## no longer diagonal, but remain sparse:
240                                 x <- as(x, "sparseMatrix")
241                                 x[i] <- value
242                                 x
243                             }
244                         }
245                         else { # behave as "base R": use as if vector
246                             x <- as(x, "matrix")
247                             x[i] <- value
248                             Matrix(x)
249                         }
250                   })                   })
251    
252    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing",
253                                    j = "index", value = "replValue"),
254                     function(x, j, value) replDiag(x, j=j, value=value))
255    
256    
257  setMethod("t", signature(x = "diagonalMatrix"),  setMethod("t", signature(x = "diagonalMatrix"),
258            function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })            function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })
# Line 203  Line 273 
273  ## chol(L) is L for logical diagonal:  ## chol(L) is L for logical diagonal:
274  setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)  setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)
275    
   
 setMethod("diag", signature(x = "diagonalMatrix"),  
           function(x = 1, nrow, ncol = n) {  
              if(x@diag == "U")  
                  rep.int(if(is.logical(x@x)) TRUE else 1, x@Dim[1])  
              else x@x  
           })  
   
 setMethod("!", "ldiMatrix", function(e1) {  
     if(e1@diag == "N")  
         e1@x <- !e1@x  
     else { ## "U"  
         e1@diag <- "N"  
         e1@x <- rep.int(FALSE, e1@Dim[1])  
     }  
     x  
 })  
   
276  ## Basic Matrix Multiplication {many more to add}  ## Basic Matrix Multiplication {many more to add}
277  ##       ---------------------  ##       ---------------------
278  ## Note that "ldi" logical are treated as numeric  ## Note that "ldi" logical are treated as numeric
# Line 313  Line 365 
365  ##        function(x, y = NULL) {  ##        function(x, y = NULL) {
366  ##           })  ##           })
367    
368    setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
369              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
370    
371    setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
372              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
373    
374    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
375              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
376    
377    setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
378              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
379    
380    
381    ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
382    setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
383              function(x, y) as(x, "sparseMatrix") %*% y)
384    ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)
385    ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
386    ## ==> do this:
387    setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
388              function(x, y) as(x, "CsparseMatrix") %*% y)
389    setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
390              function(x, y) x %*% as(y, "CsparseMatrix"))
391    ## NB: this is *not* needed for Tsparse & Rsparse
392    ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
393    ##       do indeed work by going through sparse (and *not* ddense)!
394    
395    setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
396              function(x, y) x %*% as(y, "sparseMatrix"))
397    
398    
399    setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
400              function(a, b, ...) {
401                  a@x <- 1/ a@x
402                  a@Dimnames <- a@Dimnames[2:1]
403                  a
404              })
405    
406    solveDiag <- function(a, b, ...) {
407        if((n <- a@Dim[1]) != nrow(b))
408            stop("incompatible matrix dimensions")
409        ## trivially invert a 'in place' and multiply:
410        a@x <- 1/ a@x
411        a@Dimnames <- a@Dimnames[2:1]
412        a %*% b
413    }
414    setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
415              solveDiag)
416    setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
417              solveDiag)
418    
419    
420    
421    
422  ### ---------------- diagonal  o  sparse  -----------------------------  ### ---------------- diagonal  o  sparse  -----------------------------
423    
# Line 343  Line 448 
448  setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ddiMatrix"),  setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ddiMatrix"),
449            diagOdiag)            diagOdiag)
450    
451    ## FIXME:    diagonal  o  triangular  |-->  triangular
452    ## -----     diagonal  o  symmetric   |-->  symmetric
453    ##    {also when other is sparse: do these "here" --
454    ##     before conversion to sparse, since that loses "diagonality"}
455    
456  ## For almost everything else, diag* shall be treated "as sparse" :  ## For almost everything else, diag* shall be treated "as sparse" :
457  ## These are cheap implementations via coercion  ## These are cheap implementations via coercion
458    
# Line 359  Line 469 
469    
470    
471    
 ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()  
 setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),  
           function(x, y) as(x, "sparseMatrix") %*% y)  
 ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)  
 ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.  
 ## ==> do this:  
 setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  
           function(x, y) as(x, "CsparseMatrix") %*% y)  
 ## NB: this is *not* needed for Tsparse & Rsparse  
 ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*  
 ##       do indeed work by going throug sparse (and *not* ddense)!  
   
 setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),  
           function(x, y) x %*% as(y, "sparseMatrix"))  
   
 setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  
           function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })  
   
 setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),  
           function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })  
   
 setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  
           function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })  
   
 setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),  
           function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })  
   
   
   
   
472  ## similar to prTriang() in ./Auxiliaries.R :  ## similar to prTriang() in ./Auxiliaries.R :
473  prDiag <-  prDiag <-
474      function(x, digits = getOption("digits"), justify = "none", right = TRUE)      function(x, digits = getOption("digits"), justify = "none", right = TRUE)

Legend:
Removed from v.1682  
changed lines
  Added in v.2096

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