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 3046, Mon Feb 16 14:40:37 2015 UTC revision 3069, Thu Mar 26 10:00:49 2015 UTC
# Line 577  Line 577 
577          return(y)          return(y)
578  }  }
579    
580    ##' Boolean Algebra/Arithmetic Product of Diagonal Matrices
581    ##'  %&%
582    diagdiagprodBool <- function(x, y) {
583        dimCheck(x,y)
584        if(x@diag != "U") {
585            if(!is.logical(x@x)) x <- as(x, "lMatrix")
586            if(y@diag != "U") {
587                nx <- x@x & y@x
588                x@x <- as.logical(nx)
589            }
590            x
591        } else { ## x is unit diagonal: return y
592            if(!is.logical(y@x)) y <- as(y, "lMatrix")
593            y
594        }
595    }
596    
597  setMethod("%*%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
598            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
599    
600  formals(diagdiagprod) <- alist(x=, y=x)  setMethod("%&%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
601              diagdiagprodBool, valueClass = "ldiMatrix")# do *not* have "ndiMatrix" !
602    
603    formals(diagdiagprod) <- alist(x=, y=NULL, ...=)
604    ##                                  -----  ---  matching the [t]crossprod generic
605  setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
606            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
607  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
608            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
609    
610    ##' crossprod(x) := x'x
611    diagprod <- function(x, y=NULL, ...) {
612        if(x@diag != "U") {
613            nx <- x@x * x@x
614            if(is.numeric(nx) && !is.numeric(x@x))
615                x <- as(x, "dMatrix")
616            x@x <- as.numeric(nx)
617        }
618        x
619    }
620  setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),
621            diagdiagprod, valueClass = "ddiMatrix")            diagprod, valueClass = "ddiMatrix")
622  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),
623            diagdiagprod, valueClass = "ddiMatrix")            diagprod, valueClass = "ddiMatrix")
624    
625    
626  ## analogous to matdiagprod() below:  ## analogous to matdiagprod() below:
# Line 599  Line 631 
631  }  }
632  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"),
633            diagmatprod)            diagmatprod)
634  ## sneaky .. :  
635  formals(diagmatprod) <- alist(x=, y=NULL)  formals(diagmatprod) <- alist(x=, y=NULL, ...=)
636  setMethod("crossprod",  signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)  setMethod("crossprod",  signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)
637    
638  diagGeprod <- function(x, y) {  diagGeprod <- function(x, y) {
# Line 611  Line 643 
643  }  }
644  setMethod("%*%", signature(x= "diagonalMatrix", y= "dgeMatrix"), diagGeprod)  setMethod("%*%", signature(x= "diagonalMatrix", y= "dgeMatrix"), diagGeprod)
645  setMethod("%*%", signature(x= "diagonalMatrix", y= "lgeMatrix"), diagGeprod)  setMethod("%*%", signature(x= "diagonalMatrix", y= "lgeMatrix"), diagGeprod)
646  formals(diagGeprod) <- alist(x=, y=NULL)  formals(diagGeprod) <- alist(x=, y=NULL, ...=)
647  setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "dgeMatrix"),
648            diagGeprod, valueClass = "dgeMatrix")            diagGeprod, valueClass = "dgeMatrix")
649  setMethod("crossprod", signature(x = "diagonalMatrix", y = "lgeMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "lgeMatrix"),
650            diagGeprod)            diagGeprod)
651    
652    diagGeprodBool <- function(x, y) {
653        if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")
654        if(!is.logical(y@x)) y <- as(y, "lMatrix")
655        if(x@diag != "U")
656            y@x <- x@x & y@x
657        y
658    }
659    setMethod("%&%", signature(x= "diagonalMatrix", y= "geMatrix"), diagGeprodBool)
660    
661    
662  ## analogous to diagmatprod() above:  ## analogous to diagmatprod() above:
663  matdiagprod <- function(x, y) {  matdiagprod <- function(x, y) {
664      dx <- dim(x)      dx <- dim(x)
# Line 624  Line 666 
666      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]))
667  }  }
668  setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)  setMethod("%*%", signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)
669  formals(matdiagprod) <- alist(x=, y=NULL)  formals(matdiagprod) <- alist(x=, y=NULL, ...=)
670  setMethod("tcrossprod",signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)  setMethod("tcrossprod",signature(x = "matrix", y = "diagonalMatrix"), matdiagprod)
671  setMethod("crossprod", signature(x = "matrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "matrix", y = "diagonalMatrix"),
672            function(x, y=NULL) {            function(x, y=NULL, ...) {
673                dx <- dim(x)                dx <- dim(x)
674                if(dx[1] != y@Dim[1]) stop("non-matching dimensions")                if(dx[1] != y@Dim[1]) stop("non-matching dimensions")
675                Matrix(t(rep.int(y@x, dx[2]) * x))                Matrix(t(rep.int(y@x, dx[2]) * x))
# Line 642  Line 684 
684  }  }
685  setMethod("%*%", signature(x= "dgeMatrix", y= "diagonalMatrix"), gediagprod)  setMethod("%*%", signature(x= "dgeMatrix", y= "diagonalMatrix"), gediagprod)
686  setMethod("%*%", signature(x= "lgeMatrix", y= "diagonalMatrix"), gediagprod)  setMethod("%*%", signature(x= "lgeMatrix", y= "diagonalMatrix"), gediagprod)
687  formals(gediagprod) <- alist(x=, y=NULL)  formals(gediagprod) <- alist(x=, y=NULL, ...=)
688  setMethod("tcrossprod", signature(x = "dgeMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "dgeMatrix", y = "diagonalMatrix"),
689            gediagprod)            gediagprod)
690  setMethod("tcrossprod", signature(x = "lgeMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "lgeMatrix", y = "diagonalMatrix"),
691            gediagprod)            gediagprod)
692    
693    gediagprodBool <- function(x, y) {
694        dx <- dim(x)
695        if(dx[2] != y@Dim[1]) stop("non-matching dimensions")
696        if(!is.logical(x@x)) x <- as(x, "lMatrix")
697        if(y@diag == "N")
698            x@x <- x@x & rep(y@x, each = dx[1])
699        x
700    }
701    setMethod("%&%", signature(x= "geMatrix", y= "diagonalMatrix"), gediagprodBool)
702    
703  ## crossprod {more of these}  ## crossprod {more of these}
704    
705  ## tcrossprod --- all are not yet there: do the dense ones here:  ## tcrossprod --- all are not yet there: do the dense ones here:
# Line 666  Line 718 
718  ##' @param x CsparseMatrix  ##' @param x CsparseMatrix
719  ##' @param y diagonalMatrix  ##' @param y diagonalMatrix
720  ##' @return x %*% y  ##' @return x %*% y
721  Cspdiagprod <- function(x, y) {  Cspdiagprod <- function(x, y, boolArith = NA) {
722      m <- ncol(x <- .Call(Csparse_diagU2N, x))      if((m <- ncol(x)) != y@Dim[1]) stop("non-matching dimensions")
     if(m != y@Dim[1]) stop("non-matching dimensions")  
723      if(y@diag == "N") { ## otherwise: y == Diagonal(n) : multiplication is identity      if(y@diag == "N") { ## otherwise: y == Diagonal(n) : multiplication is identity
724          if(!all(y@x[1L] == y@x[-1L]) && is(x, "symmetricMatrix"))          x <- .Call(Csparse_diagU2N, x)
725            cx <- getClass(class(x))
726            if(!all(y@x[1L] == y@x[-1L]) && extends(cx, "symmetricMatrix"))
727              x <- as(x, "generalMatrix")              x <- as(x, "generalMatrix")
728          ind <- rep.int(seq_len(m), x@p[-1] - x@p[-m-1L])          ind <- rep.int(seq_len(m), x@p[-1] - x@p[-m-1L])
729            if(isTRUE(boolArith)) {
730                if(extends(cx, "nMatrix")) x <- as(x, "lMatrix") # so, has y@x
731                x@x <- x@x & y@x[x@i + 1L]
732                if(!extends(cx, "diagonalMatrix")) x <- as(drop0(x), "nMatrix")
733            } else {
734                if(!extends(cx, "dMatrix")) x <- as(x, "dMatrix") # <- FIXME if we have zMatrix
735          x@x <- x@x * y@x[ind]          x@x <- x@x * y@x[ind]
736            }
737          if(.hasSlot(x, "factors") && length(x@factors)) {# drop cashed ones          if(.hasSlot(x, "factors") && length(x@factors)) {# drop cashed ones
738              ## instead of dropping all factors, be smart about some              ## instead of dropping all factors, be smart about some
739              ## TODO ......              ## TODO ......
# Line 686  Line 746 
746  ##' @param x diagonalMatrix  ##' @param x diagonalMatrix
747  ##' @param y CsparseMatrix  ##' @param y CsparseMatrix
748  ##' @return x %*% y  ##' @return x %*% y
749  diagCspprod <- function(x, y) {  diagCspprod <- function(x, y, boolArith = FALSE) {
     y <- .Call(Csparse_diagU2N, y)  
750      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")
751      if(x@diag == "N") {      if(x@diag == "N") {
752          if(!all(x@x[1L] == x@x[-1L]) && is(y, "symmetricMatrix"))          y <- .Call(Csparse_diagU2N, y)
753            cy <- getClass(class(y))
754            if(!all(x@x[1L] == x@x[-1L]) && extends(cy, "symmetricMatrix"))
755              y <- as(y, "generalMatrix")              y <- as(y, "generalMatrix")
756            if(isTRUE(boolArith)) {
757                if(extends(cy, "nMatrix")) y <- as(y, "lMatrix") # so, has y@x
758                y@x <- y@x & x@x[y@i + 1L]
759                if(!extends(cy, "diagonalMatrix")) y <- as(drop0(y), "nMatrix")
760            } else {
761                if(!extends(cy, "dMatrix")) y <- as(y, "dMatrix") # <- FIXME if we have zMatrix
762          y@x <- y@x * x@x[y@i + 1L]          y@x <- y@x * x@x[y@i + 1L]
763            }
764          if(.hasSlot(y, "factors") && length(y@factors)) {          if(.hasSlot(y, "factors") && length(y@factors)) {
765       ## if(.hasSlot(y, "factors") && length(yf <- y@factors)) { ## -- TODO? --       ## if(.hasSlot(y, "factors") && length(yf <- y@factors)) { ## -- TODO? --
766              ## instead of dropping all factors, be smart about some              ## instead of dropping all factors, be smart about some
# Line 707  Line 775 
775      y      y
776  }  }
777    
778    ## + 'boolArith' argument  { ==> .local() is used in any case; keep formals simple :}
779  setMethod("crossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
780            function(x, y = NULL) diagCspprod(x, y))            function(x, y, boolArith=NA) diagCspprod(x, y, boolArith=boolArith))
781    
782  setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
783            function(x, y = NULL) diagCspprod(x, as(y, "CsparseMatrix")))            function(x, y, boolArith=NA)
784                  diagCspprod(x, as(y, "CsparseMatrix"), boolArith=boolArith))
785    
786  ## Prefer calling diagCspprod to Cspdiagprod if going to transpose anyway  ## Prefer calling diagCspprod to Cspdiagprod if going to transpose anyway
787  ##  x'y == (y'x)'  ##  x'y == (y'x)'
788  setMethod("crossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
789            function(x, y = NULL) t(diagCspprod(y, x)))            function(x, y, boolArith=NA) t(diagCspprod(y, x, boolArith=boolArith)))
790    
791  setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
792            function(x, y = NULL) t(diagCspprod(y, as(x, "Csparsematrix"))))            function(x, y, boolArith=NA) t(diagCspprod(y, as(x, "Csparsematrix"), boolArith=boolArith)))
793    
794  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
795            function(x, y = NULL) diagCspprod(x, t(y)))            function(x, y, boolArith=NA) diagCspprod(x, t(y), boolArith=boolArith))
796    
797  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
798            function(x, y = NULL) diagCspprod(x, t(as(y, "CsparseMatrix"))))            function(x, y, boolArith=NA) diagCspprod(x, t(as(y, "CsparseMatrix")), boolArith=boolArith))
799    
800  setMethod("tcrossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
801            function(x, y = NULL) Cspdiagprod(x, y))            function(x, y, boolArith=NA) Cspdiagprod(x, y, boolArith=boolArith))
802    
803  setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
804            function(x, y = NULL) Cspdiagprod(as(x, "CsparseMatrix"), y))            function(x, y, boolArith=NA) Cspdiagprod(as(x, "CsparseMatrix"), y, boolArith=boolArith))
805    
806  setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
807            function(x, y) diagCspprod(x, y))            function(x, y) diagCspprod(x, y, boolArith=NA))
808    setMethod("%&%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
809              function(x, y) diagCspprod(x, y, boolArith=TRUE))
810    
811  ## instead of "sparseMatrix", use: [RT]sparse.. ("closer" in method dispatch)  ## instead of "sparseMatrix", use: [RT]sparse.. ("closer" in method dispatch)
812  for(cl in c("TsparseMatrix", "RsparseMatrix")) {  for(cl in c("TsparseMatrix", "RsparseMatrix")) {
813    
814  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
815            function(x, y) diagCspprod(as(x, "CsparseMatrix"), y))            function(x, y) diagCspprod(as(x, "CsparseMatrix"), y, boolArith=NA))
816    
817  setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
818            function(x, y) Cspdiagprod(as(x, "CsparseMatrix"), y))            function(x, y) Cspdiagprod(as(x, "CsparseMatrix"), y, boolArith=NA))
819    
820    setMethod("%&%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
821              function(x, y) diagCspprod(as(x, "CsparseMatrix"), y, boolArith=TRUE))
822    
823    setMethod("%&%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
824              function(x, y) Cspdiagprod(as(x, "CsparseMatrix"), y, boolArith=TRUE))
825    
826  }  }
827    
828  setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
829            function(x, y) Cspdiagprod(x, y))            function(x, y) Cspdiagprod(x, y, boolArith=NA))
830    setMethod("%&%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
831              function(x, y) Cspdiagprod(x, y, boolArith=TRUE))
832    
833  ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*  ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
834  ##       do indeed work by going through sparse (and *not* ddense)!  ##       do indeed work by going through sparse (and *not* ddense)!
# Line 1085  Line 1166 
1166  }  }
1167    
1168  ## Direct subclasses of "denseMatrix": currently ddenseMatrix, ldense... :  ## Direct subclasses of "denseMatrix": currently ddenseMatrix, ldense... :
1169    if(FALSE) # now also contains "geMatrix"
1170  dense.subCl <- local({ dM.scl <- getClass("denseMatrix")@subclasses  dense.subCl <- local({ dM.scl <- getClass("denseMatrix")@subclasses
1171                         names(dM.scl)[vapply(dM.scl, slot, 0, "distance") == 1] })                         names(dM.scl)[vapply(dM.scl, slot, 0, "distance") == 1] })
1172    dense.subCl <- paste0(c("d","l","n"), "denseMatrix")
1173  for(DI in diCls) {  for(DI in diCls) {
1174      dMeth <- if(extends(DI, "dMatrix"))      dMeth <- if(extends(DI, "dMatrix"))
1175          function(e1,e2) callGeneric(diag2Tsmart(e1,e2, "d"), e2)          function(e1,e2) callGeneric(diag2Tsmart(e1,e2, "d"), e2)

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

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