SCM Repository

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

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

revision 3069, Thu Mar 26 10:00:49 2015 UTC revision 3072, Fri Mar 27 15:10:48 2015 UTC
# Line 600  Line 600
600  setMethod("%&%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),  setMethod("%&%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
601            diagdiagprodBool, valueClass = "ldiMatrix")# do *not* have "ndiMatrix" !            diagdiagprodBool, valueClass = "ldiMatrix")# do *not* have "ndiMatrix" !
602
603  formals(diagdiagprod) <- alist(x=, y=NULL, ...=)  ##' Both Numeric or Boolean Algebra/Arithmetic Product of Diagonal Matrices
604  ##                                  -----  ---  matching the [t]crossprod generic  diagdiagprodFlexi <- function(x, y=NULL, boolArith = NA, ...)
605    {
606        dimCheck(x,y)
607        bool <- isTRUE(boolArith)
608        if(x@diag != "U") {
609            if(bool && !is.logical(x@x)) x <- as(x, "lMatrix")
610            if(y@diag != "U") {
611                if(bool) {
612                    nx <- x@x & y@x
613                    x@x <- as.logical(nx)
614                } else { ## boolArith is NA or FALSE: ==> numeric, as have *no* "diagMatrix" patter[n]:
615                    nx <- x@x * y@x
616                    if(is.numeric(nx) && !is.numeric(x@x))
617                        x <- as(x, "dMatrix")
618                    x@x <- as.numeric(nx)
619                }
620            }
621            x
622        } else { ## x is unit diagonal: return y
623            if(bool && !is.logical(y@x)) y <- as(y, "lMatrix")
624            y
625        }
626    }
627  setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
628            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprodFlexi)
629  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
630            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprodFlexi)
631
632  ##' crossprod(x) := x'x  ##' crossprod(x) := x'x
633  diagprod <- function(x, y=NULL, ...) {  diagprod <- function(x, y = NULL, boolArith = NA, ...) {
634        bool <- isTRUE(boolArith)
635        if(bool && !is.logical(x@x)) x <- as(x, "lMatrix")
636      if(x@diag != "U") {      if(x@diag != "U") {
637            if(bool) {
638                nx <- x@x & y@x
639                x@x <- as.logical(nx)
640            } else { ## boolArith is NA or FALSE: ==> numeric, as have *no* "diagMatrix" patter[n]:
641          nx <- x@x * x@x          nx <- x@x * x@x
642          if(is.numeric(nx) && !is.numeric(x@x))          if(is.numeric(nx) && !is.numeric(x@x))
643              x <- as(x, "dMatrix")              x <- as(x, "dMatrix")
644          x@x <- as.numeric(nx)          x@x <- as.numeric(nx)
645      }      }
646        }
647      x      x
648  }  }
649  setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),  setMethod( "crossprod", signature(x = "diagonalMatrix", y = "missing"), diagprod)
650            diagprod, valueClass = "ddiMatrix")  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"), diagprod)
setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),
diagprod, valueClass = "ddiMatrix")
651
652
653  ## analogous to matdiagprod() below:  ## analogous to matdiagprod() below:
# Line 629  Line 656
656      if(x@Dim[2] != nrow(y)) stop("non-matching dimensions")      if(x@Dim[2] != nrow(y)) stop("non-matching dimensions")
657      Matrix(if(x@diag == "U") y else x@x * y)      Matrix(if(x@diag == "U") y else x@x * y)
658  }  }
659  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)
diagmatprod)
660
661  formals(diagmatprod) <- alist(x=, y=NULL, ...=)  formals(diagmatprod) <- alist(x=, y=NULL, boolArith = NA, ...=)
662  setMethod("crossprod",  signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)  setMethod("crossprod",  signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)
663
664  diagGeprod <- function(x, y) {  diagGeprod <- function(x, y) {
# Line 643  Line 669
669  }  }
670  setMethod("%*%", signature(x= "diagonalMatrix", y= "dgeMatrix"), diagGeprod)  setMethod("%*%", signature(x= "diagonalMatrix", y= "dgeMatrix"), diagGeprod)
671  setMethod("%*%", signature(x= "diagonalMatrix", y= "lgeMatrix"), diagGeprod)  setMethod("%*%", signature(x= "diagonalMatrix", y= "lgeMatrix"), diagGeprod)
formals(diagGeprod) <- alist(x=, y=NULL, ...=)
setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),
diagGeprod, valueClass = "dgeMatrix")
setMethod("crossprod", signature(x = "diagonalMatrix", y = "lgeMatrix"),
diagGeprod)
672
673  diagGeprodBool <- function(x, y) {  diagGeprodBool <- function(x, y) {
674      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")
# Line 658  Line 679
679  }  }
680  setMethod("%&%", signature(x= "diagonalMatrix", y= "geMatrix"), diagGeprodBool)  setMethod("%&%", signature(x= "diagonalMatrix", y= "geMatrix"), diagGeprodBool)
681
682    diagGeprod2 <- function(x, y=NULL, boolArith = NA, ...) {
683        if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")
684        bool <- isTRUE(boolArith)
685        if(bool && !is.logical(y@x)) y <- as(y, "lMatrix")
686        if(x@diag != "U")
687            y@x <- if(bool) x@x & y@x else x@x * y@x
688        y
689    }
690    setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"), diagGeprod2)
691    setMethod("crossprod", signature(x = "diagonalMatrix", y = "lgeMatrix"), diagGeprod2)
692
693
694  ## analogous to diagmatprod() above:  ## analogous to diagmatprod() above:
695  matdiagprod <- function(x, y) {  matdiagprod <- function(x, y) {
# Line 666  Line 698
698      Matrix(if(y@diag == "U") x else x * rep(y@x, each = dx[1]))      Matrix(if(y@diag == "U") x else x * rep(y@x, each = dx[1]))
699  }  }
700  setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)  setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)
formals(matdiagprod) <- alist(x=, y=NULL, ...=)
setMethod("tcrossprod",signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)
setMethod("crossprod", signature(x = "matrix", y = "diagonalMatrix"),
function(x, y=NULL, ...) {
dx <- dim(x)
if(dx[1] != y@Dim[1]) stop("non-matching dimensions")
Matrix(t(rep.int(y@x, dx[2]) * x))
})
701
702  gediagprod <- function(x, y) {  gediagprod <- function(x, y) {
703      dx <- dim(x)      dx <- dim(x)
# Line 684  Line 708
708  }  }
709  setMethod("%*%", signature(x= "dgeMatrix", y= "diagonalMatrix"), gediagprod)  setMethod("%*%", signature(x= "dgeMatrix", y= "diagonalMatrix"), gediagprod)
710  setMethod("%*%", signature(x= "lgeMatrix", y= "diagonalMatrix"), gediagprod)  setMethod("%*%", signature(x= "lgeMatrix", y= "diagonalMatrix"), gediagprod)
formals(gediagprod) <- alist(x=, y=NULL, ...=)
setMethod("tcrossprod", signature(x = "dgeMatrix", y = "diagonalMatrix"),
gediagprod)
setMethod("tcrossprod", signature(x = "lgeMatrix", y = "diagonalMatrix"),
gediagprod)
711
712  gediagprodBool <- function(x, y) {  gediagprodBool <- function(x, y) {
713      dx <- dim(x)      dx <- dim(x)
# Line 700  Line 719
719  }  }
720  setMethod("%&%", signature(x= "geMatrix", y= "diagonalMatrix"), gediagprodBool)  setMethod("%&%", signature(x= "geMatrix", y= "diagonalMatrix"), gediagprodBool)
721
722    setMethod("tcrossprod",signature(x = "matrix", y = "diagonalMatrix"),
723              function(x, y=NULL, boolArith = NA, ...) {
724                  dx <- dim(x)
725                  if(dx[2] != y@Dim[1]) stop("non-matching dimensions")
726                  bool <- isTRUE(boolArith)
727                  if(bool && !is.logical(y@x)) y <- as(y, "lMatrix")
728                  Matrix(if(y@diag == "U") x else
729                         if(bool) x & rep(y@x, each = dx[1])
730                         else     x * rep(y@x, each = dx[1]))
731              })
732
733    setMethod("crossprod", signature(x = "matrix", y = "diagonalMatrix"),
734              function(x, y=NULL, boolArith = NA, ...) {
735                  dx <- dim(x)
736                  if(dx[1] != y@Dim[1]) stop("non-matching dimensions")
737                  bool <- isTRUE(boolArith)
738                  if(bool && !is.logical(y@x)) y <- as(y, "lMatrix")
739                  Matrix(if(bool) t(rep.int(y@x, dx[2]) & x)
740                             else t(rep.int(y@x, dx[2]) * x))
741              })
742
743
744    gediagprod2 <- function(x, y=NULL, boolArith = NA, ...) {
745        dx <- dim(x)
746        if(dx[2] != y@Dim[1]) stop("non-matching dimensions")
747        bool <- isTRUE(boolArith)
748        if(bool && !is.logical(x@x)) x <- as(x, "lMatrix")
749        if(y@diag == "N")
750            x@x <- if(bool) x@x & rep(y@x, each = dx[1])
751                   else     x@x * rep(y@x, each = dx[1])
752        x
753    }
754    setMethod("tcrossprod", signature(x = "dgeMatrix", y = "diagonalMatrix"), gediagprod2)
755    setMethod("tcrossprod", signature(x = "lgeMatrix", y = "diagonalMatrix"), gediagprod2)
756
757
758  ## crossprod {more of these}  ## crossprod {more of these}
759
760  ## tcrossprod --- all are not yet there: do the dense ones here:  ## tcrossprod --- all are not yet there: do the dense ones here:
# Line 718  Line 773
773  ##' @param x CsparseMatrix  ##' @param x CsparseMatrix
774  ##' @param y diagonalMatrix  ##' @param y diagonalMatrix
775  ##' @return x %*% y  ##' @return x %*% y
776  Cspdiagprod <- function(x, y, boolArith = NA) {  Cspdiagprod <- function(x, y, boolArith = NA, ...) {
777      if((m <- ncol(x)) != y@Dim[1]) stop("non-matching dimensions")      if((m <- ncol(x)) != y@Dim[1]) stop("non-matching dimensions")
778      if(y@diag == "N") { ## otherwise: y == Diagonal(n) : multiplication is identity      if(y@diag == "N") { ## otherwise: y == Diagonal(n) : multiplication is identity
779          x <- .Call(Csparse_diagU2N, x)          x <- .Call(Csparse_diagU2N, x)
# Line 746  Line 801
801  ##' @param x diagonalMatrix  ##' @param x diagonalMatrix
802  ##' @param y CsparseMatrix  ##' @param y CsparseMatrix
803  ##' @return x %*% y  ##' @return x %*% y
804  diagCspprod <- function(x, y, boolArith = FALSE) {  diagCspprod <- function(x, y, boolArith = NA, ...) {
805      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")
806      if(x@diag == "N") {      if(x@diag == "N") {
807          y <- .Call(Csparse_diagU2N, y)          y <- .Call(Csparse_diagU2N, y)
# Line 777  Line 832
832
833  ## + 'boolArith' argument  { ==> .local() is used in any case; keep formals simple :}  ## + 'boolArith' argument  { ==> .local() is used in any case; keep formals simple :}
834  setMethod("crossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
835            function(x, y, boolArith=NA) diagCspprod(x, y, boolArith=boolArith))            function(x, y=NULL, boolArith=NA, ...) diagCspprod(x, y, boolArith=boolArith))
836
837  setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
838            function(x, y, boolArith=NA)            function(x, y=NULL, boolArith=NA, ...)
839                diagCspprod(x, as(y, "CsparseMatrix"), boolArith=boolArith))                diagCspprod(x, as(y, "CsparseMatrix"), boolArith=boolArith))
840
841  ## Prefer calling diagCspprod to Cspdiagprod if going to transpose anyway  ## Prefer calling diagCspprod to Cspdiagprod if going to transpose anyway
842  ##  x'y == (y'x)'  ##  x'y == (y'x)'
843  setMethod("crossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
844            function(x, y, boolArith=NA) t(diagCspprod(y, x, boolArith=boolArith)))            function(x, y=NULL, boolArith=NA, ...) t(diagCspprod(y, x, boolArith=boolArith)))
845
846  setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
847            function(x, y, boolArith=NA) t(diagCspprod(y, as(x, "Csparsematrix"), boolArith=boolArith)))            function(x, y=NULL, boolArith=NA, ...) t(diagCspprod(y, as(x, "Csparsematrix"), boolArith=boolArith)))
848
849  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
850            function(x, y, boolArith=NA) diagCspprod(x, t(y), boolArith=boolArith))            function(x, y=NULL, boolArith=NA, ...) diagCspprod(x, t(y), boolArith=boolArith))
851
852  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
853            function(x, y, boolArith=NA) diagCspprod(x, t(as(y, "CsparseMatrix")), boolArith=boolArith))            function(x, y=NULL, boolArith=NA, ...) diagCspprod(x, t(as(y, "CsparseMatrix")), boolArith=boolArith))
854
855  setMethod("tcrossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
856            function(x, y, boolArith=NA) Cspdiagprod(x, y, boolArith=boolArith))            function(x, y=NULL, boolArith=NA, ...) Cspdiagprod(x, y, boolArith=boolArith))
857
858  setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
859            function(x, y, boolArith=NA) Cspdiagprod(as(x, "CsparseMatrix"), y, boolArith=boolArith))            function(x, y=NULL, boolArith=NA, ...) Cspdiagprod(as(x, "CsparseMatrix"), y, boolArith=boolArith))
860
861  setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
862            function(x, y) diagCspprod(x, y, boolArith=NA))            function(x, y) diagCspprod(x, y, boolArith=NA))

Legend:
 Removed from v.3069 changed lines Added in v.3072