SCM Repository

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

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

revision 2904, Tue Sep 10 19:43:53 2013 UTC revision 2912, Sat Sep 14 17:09:49 2013 UTC
# Line 654  Line 654
654  ##        function(x, y = NULL) {  ##        function(x, y = NULL) {
655  ##           })  ##           })
656
657    ##' @param x CsparseMatrix
658    ##' @param y diagonalMatrix
659    ##' @return x %*% y
660  Cspdiagprod <- function(x, y) {  Cspdiagprod <- function(x, y) {
661      dx <- dim(x <- .Call(Csparse_diagU2N, x))      dx <- dim(x <- .Call(Csparse_diagU2N, x))
662      dy <- dim(y)      dy <- dim(y)
663      if(dx[2] != dy[1]) stop("non-matching dimensions")      if(dx[2] != dy[1]) stop("non-matching dimensions")
664      if(y@diag == "N") {      if(y@diag == "N") { ## otherwise: y == Diagonal(n) : multiplication is identity
665          if(!all(y@x[1L] == y@x[-1L]) && is(x, "symmetricMatrix"))          if(!all(y@x[1L] == y@x[-1L]) && is(x, "symmetricMatrix"))
666              x <- as(x, "generalMatrix")              x <- as(x, "generalMatrix")
667          ind <- rep.int(seq_len(dx[2]), x@p[-1] - x@p[-dx[2]-1L])          ind <- rep.int(seq_len(dx[2]), x@p[-1] - x@p[-dx[2]-1L])
668          x@x <- x@x * y@x[ind]          x@x <- x@x * y@x[ind]
}
669      if(is(x, "compMatrix") && length(xf <- x@factors)) {      if(is(x, "compMatrix") && length(xf <- x@factors)) {
671          ## TODO ......          ## TODO ......
672          x@factors <- list()          x@factors <- list()
673      }      }
674        }
675      x      x
676  }  }
677
678    ##' @param x diagonalMatrix
679    ##' @param y CsparseMatrix
680    ##' @return x %*% y
681  diagCspprod <- function(x, y) {  diagCspprod <- function(x, y) {
682      dx <- dim(x)      dx <- dim(x)
683      dy <- dim(y <- .Call(Csparse_diagU2N, y))      dy <- dim(y <- .Call(Csparse_diagU2N, y))
# Line 680  Line 686
686          if(!all(x@x[1L] == x@x[-1L]) && is(y, "symmetricMatrix"))          if(!all(x@x[1L] == x@x[-1L]) && is(y, "symmetricMatrix"))
687              y <- as(y, "generalMatrix")              y <- as(y, "generalMatrix")
688          y@x <- y@x * x@x[y@i + 1L]          y@x <- y@x * x@x[y@i + 1L]
}
689      if(is(y, "compMatrix") && length(yf <- y@factors)) {      if(is(y, "compMatrix") && length(yf <- y@factors)) {
690          ## TODO          ## TODO
691                if(FALSE) { ## instead of dropping all factors, be smart about some
692          keep <- character()          keep <- character()
693          if(iLU <- names(yf) == "LU") {                  if(any(iLU <- names(yf) == "LU")) {
694              ## TODO keep <- "LU"                      keep <- "LU"
695          }          }
696          y@factors <- yf[keep]          y@factors <- yf[keep]
697                } else y@factors <- list() ## for now
698            }
699      }      }
700      y      y
701  }  }
# Line 722  Line 729
729  setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
730            function(x, y) diagCspprod(x, y))            function(x, y) diagCspprod(x, y))
731
732    ## instead of "sparseMatrix", use: [RT]sparse.. ("closer" in method dispatch)
733    for(cl in c("TsparseMatrix", "RsparseMatrix")) {
734
735  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
736            function(x, y) diagCspprod(as(x, "CsparseMatrix"), y))            function(x, y) diagCspprod(as(x, "CsparseMatrix"), y))
737
738  setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
739            function(x, y) Cspdiagprod(as(x, "CsparseMatrix"), y))            function(x, y) Cspdiagprod(as(x, "CsparseMatrix"), y))
740    }
741
742  setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
743            function(x, y) Cspdiagprod(x, y))            function(x, y) Cspdiagprod(x, y))

Legend:
 Removed from v.2904 changed lines Added in v.2912