# SCM Repository

[matrix] Diff of /pkg/R/diagMatrix.R
 [matrix] / pkg / R / diagMatrix.R

# Diff of /pkg/R/diagMatrix.R

revision 2182, Thu Apr 24 10:57:08 2008 UTC revision 2183, Thu Apr 24 10:58:51 2008 UTC
# Line 223  Line 223
223
224  setAs("ldiMatrix", "lgCMatrix",  setAs("ldiMatrix", "lgCMatrix",
225        function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))        function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
226  }  }##{unused}

227
if(FALSE) # now have faster  "ddense" -> "dge"
228  setAs("ddiMatrix", "dgeMatrix",  setAs("ddiMatrix", "dgeMatrix",
229        function(from) as(as(from, "matrix"), "dgeMatrix"))        function(from) .Call(dup_mMatrix_as_dgeMatrix, from))
230    setAs("ddiMatrix", "ddenseMatrix",
231          function(from) as(as(from, "triangularMatrix"),"denseMatrix"))
232    setAs("ldiMatrix", "ldenseMatrix",
233          function(from) as(as(from, "triangularMatrix"),"denseMatrix"))
234
235
236  setAs("matrix", "diagonalMatrix",  setAs("matrix", "diagonalMatrix",
237        function(from) {        function(from) {
# Line 373  Line 376
376
377  setMethod("chol", signature(x = "ddiMatrix"),  setMethod("chol", signature(x = "ddiMatrix"),
378            function(x, pivot, ...) {            function(x, pivot, ...) {
379                  if(x@diag == "U") return(x)
380                  ## else
381                if(any(x@x < 0))                if(any(x@x < 0))
382                    stop("chol() is undefined for diagonal matrix with negative entries")                    stop("chol() is undefined for diagonal matrix with negative entries")
383                x@x <- sqrt(x@x)                x@x <- sqrt(x@x)
# Line 382  Line 387
387  setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot, ...) x)  setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot, ...) x)
388
389  setMethod("determinant", signature(x = "diagonalMatrix", logarithm = "logical"),  setMethod("determinant", signature(x = "diagonalMatrix", logarithm = "logical"),
390            function(x, logarithm, ...) mkDet(x@x, logarithm))            function(x, logarithm, ...)
391              mkDet(if(x@diag == "U") rep.int(as1(x@x), x@Dim[1]) else x@x,
392                    logarithm))
393
394    setMethod("norm", signature(x = "diagonalMatrix", type = "character"),
395              function(x, type, ...) {
396                  if((n <- x@Dim[1]) == 0) return(0) # as for "sparseMatrix"
397                  type <- toupper(substr(type[1], 1, 1))
398                  isU <- (x@diag == "U") # unit-diagonal
399                  if(type == "F") sqrt(if(isU) n else sum(x@x^2))
400                  else { ## norm == "I","1","O","M" :
401                      if(isU) 1 else max(abs(x@x))
402                  }
403              })
404
405
406
407  ## Basic Matrix Multiplication {many more to add}  ## Basic Matrix Multiplication {many more to add}
408  ##       ---------------------  ##       ---------------------
409  ## Note that "ldi" logical are treated as numeric  ## Note that "ldi" logical are treated as numeric
410  diagdiagprod <- function(x, y) {  diagdiagprod <- function(x, y) {
411      if(any(dim(x) != dim(y))) stop("non-matching dimensions")      n <- dimCheck(x,y)[1]
412      if(x@diag != "U") {      if(x@diag != "U") {
413          if(y@diag != "U") {          if(y@diag != "U") {
414              nx <- x@x * y@x              nx <- x@x * y@x
# Line 416  Line 436
436
437
438  diagmatprod <- function(x, y) {  diagmatprod <- function(x, y) {
439        ## x is diagonalMatrix
440      dx <- dim(x)      dx <- dim(x)
441      dy <- dim(y)      dy <- dim(y)
442      if(dx[2] != dy[1]) stop("non-matching dimensions")      if(dx[2] != dy[1]) stop("non-matching dimensions")
443      n <- dx[1]      n <- dx[1]
444      as(if(x@diag == "U") y else x@x * y, "Matrix")      as(if(x@diag == "U") y else x@x * y, "Matrix")
445  }  }

446  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),
447            diagmatprod)            diagmatprod)
448    ## sneaky .. :
449  formals(diagmatprod) <- alist(x=, y=NULL)  formals(diagmatprod) <- alist(x=, y=NULL)
450  setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),
451            diagmatprod)            diagmatprod)
setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "matrix"),
diagmatprod)
452
453  diagdgeprod <- function(x, y) {  diagGeprod <- function(x, y) {
454      dx <- dim(x)      dx <- dim(x)
455      dy <- dim(y)      dy <- dim(y)
456      if(dx[2] != dy[1]) stop("non-matching dimensions")      if(dx[2] != dy[1]) stop("non-matching dimensions")
# Line 439  Line 458
458          y@x <- x@x * y@x          y@x <- x@x * y@x
459      y      y
460  }  }
461  setMethod("%*%", signature(x = "diagonalMatrix", y = "dgeMatrix"),  setMethod("%*%", signature(x= "diagonalMatrix", y= "dgeMatrix"), diagGeprod)
462            diagdgeprod, valueClass = "dgeMatrix")  setMethod("%*%", signature(x= "diagonalMatrix", y= "lgeMatrix"), diagGeprod)
463  formals(diagdgeprod) <- alist(x=, y=NULL)  formals(diagGeprod) <- alist(x=, y=NULL)
464  setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),
465            diagdgeprod, valueClass = "dgeMatrix")            diagGeprod, valueClass = "dgeMatrix")
466    setMethod("crossprod", signature(x = "diagonalMatrix", y = "lgeMatrix"),
467              diagGeprod)
468
469  setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"),  matdiagprod <- function(x, y) {
function(x, y) {
470                dx <- dim(x)                dx <- dim(x)
471                dy <- dim(y)                dy <- dim(y)
472                if(dx[2] != dy[1]) stop("non-matching dimensions")                if(dx[2] != dy[1]) stop("non-matching dimensions")
473                as(if(y@diag == "U") x else x * rep(y@x, each = dx[1]), "Matrix")      Matrix(if(y@diag == "U") x else x * rep(y@x, each = dx[1]))
474            })  }
475    setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"),
476              matdiagprod)
477    formals(matdiagprod) <- alist(x=, y=NULL)
478    setMethod("tcrossprod", signature(x = "matrix", y = "diagonalMatrix"),
479              matdiagprod)
480
481  setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),  gediagprod <- function(x, y) {
function(x, y) {
482                dx <- dim(x)                dx <- dim(x)
483                dy <- dim(y)                dy <- dim(y)
484                if(dx[2] != dy[1]) stop("non-matching dimensions")                if(dx[2] != dy[1]) stop("non-matching dimensions")
485                if(y@diag == "N")                if(y@diag == "N")
486                    x@x <- x@x * rep(y@x, each = dx[1])                    x@x <- x@x * rep(y@x, each = dx[1])
487                x                x
488            })  }
489    setMethod("%*%", signature(x= "dgeMatrix", y= "diagonalMatrix"), gediagprod)
490    setMethod("%*%", signature(x= "lgeMatrix", y= "diagonalMatrix"), gediagprod)
491    formals(gediagprod) <- alist(x=, y=NULL)
492    setMethod("tcrossprod", signature(x = "dgeMatrix", y = "diagonalMatrix"),
493              gediagprod)
494    setMethod("tcrossprod", signature(x = "lgeMatrix", y = "diagonalMatrix"),
495              gediagprod)
496
497  ## crossprod {more of these}  ## crossprod {more of these}
498
499  ## tcrossprod --- all are not yet there: do the dense ones here:  ## tcrossprod --- all are not yet there: do the dense ones here:
500
501    setMethod("%*%", signature(x = "diagonalMatrix", y = "denseMatrix"),
502              function(x, y) if(x@diag == "U") y else x %*% as(y, "generalMatrix"))
503    setMethod("%*%", signature(x = "denseMatrix", y = "diagonalMatrix"),
504              function(x, y) if(y@diag == "U") x else as(x, "generalMatrix") %*% y)
505
506
507  ## FIXME:  ## FIXME:
508  ## setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "denseMatrix"),  ## setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "denseMatrix"),
509  ##        function(x, y = NULL) {  ##        function(x, y = NULL) {
# Line 492  Line 529
529  ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()  ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
530  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
531            function(x, y) as(x, "sparseMatrix") %*% y)            function(x, y) as(x, "sparseMatrix") %*% y)
532    setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
533              function(x, y) x %*% as(y, "sparseMatrix"))
534  ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)  ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)
535  ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.  ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
536  ## ==> do this:  ## ==> do this:
# Line 503  Line 542
542  ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*  ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
543  ##       do indeed work by going through sparse (and *not* ddense)!  ##       do indeed work by going through sparse (and *not* ddense)!
544
setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
function(x, y) x %*% as(y, "sparseMatrix"))
545
546
547  setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),  setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),

Legend:
 Removed from v.2182 changed lines Added in v.2183

 root@r-forge.r-project.org ViewVC Help Powered by ViewVC 1.0.0
Thanks to: