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 2904, Tue Sep 10 19:43:53 2013 UTC revision 2984, Sat Apr 12 21:37:37 2014 UTC
# Line 251  Line 251 
251  ## "hack"  instead of signature  x = "diagonalMatrix" :  ## "hack"  instead of signature  x = "diagonalMatrix" :
252  ##  ##
253  ## ddi*:  ## ddi*:
254  diag2tT <- function(from) .diag2tT(from, "U", "d")  di2tT <- function(from) .diag2tT(from, "U", "d")
255  setAs("ddiMatrix", "triangularMatrix", diag2tT)  setAs("ddiMatrix", "triangularMatrix", di2tT)
256  ##_no_longer_ setAs("ddiMatrix", "sparseMatrix", diag2tT)  ##_no_longer_ setAs("ddiMatrix", "sparseMatrix", di2tT)
257  ## needed too (otherwise <dense> -> Tsparse is taken):  ## needed too (otherwise <dense> -> Tsparse is taken):
258  setAs("ddiMatrix", "TsparseMatrix", diag2tT)  setAs("ddiMatrix", "TsparseMatrix", di2tT)
259  setAs("ddiMatrix", "dsparseMatrix", diag2tT)  setAs("ddiMatrix", "dsparseMatrix", di2tT)
260  setAs("ddiMatrix", "CsparseMatrix",  setAs("ddiMatrix", "CsparseMatrix",
261        function(from) as(.diag2tT(from, "U", "d"), "CsparseMatrix"))        function(from) as(.diag2tT(from, "U", "d"), "CsparseMatrix"))
262  setAs("ddiMatrix", "symmetricMatrix",  setAs("ddiMatrix", "symmetricMatrix",
263        function(from) .diag2sT(from, "U", "d"))        function(from) .diag2sT(from, "U", "d"))
264  ##  ##
265  ## ldi*:  ## ldi*:
266  diag2tT <- function(from) .diag2tT(from, "U", "l")  di2tT <- function(from) .diag2tT(from, "U", "l")
267  setAs("ldiMatrix", "triangularMatrix", diag2tT)  setAs("ldiMatrix", "triangularMatrix", di2tT)
268  ##_no_longer_ setAs("ldiMatrix", "sparseMatrix", diag2tT)  ##_no_longer_ setAs("ldiMatrix", "sparseMatrix", di2tT)
269  ## needed too (otherwise <dense> -> Tsparse is taken):  ## needed too (otherwise <dense> -> Tsparse is taken):
270  setAs("ldiMatrix", "TsparseMatrix", diag2tT)  setAs("ldiMatrix", "TsparseMatrix", di2tT)
271  setAs("ldiMatrix", "lsparseMatrix", diag2tT)  setAs("ldiMatrix", "lsparseMatrix", di2tT)
272  setAs("ldiMatrix", "CsparseMatrix",  setAs("ldiMatrix", "CsparseMatrix",
273        function(from) as(.diag2tT(from, "U", "l"), "CsparseMatrix"))        function(from) as(.diag2tT(from, "U", "l"), "CsparseMatrix"))
274  setAs("ldiMatrix", "symmetricMatrix",  setAs("ldiMatrix", "symmetricMatrix",
275        function(from) .diag2sT(from, "U", "l"))        function(from) .diag2sT(from, "U", "l"))
276    rm(di2tT)
277    
278  setAs("diagonalMatrix", "nMatrix",  setAs("diagonalMatrix", "nMatrix",
279        function(from) {        function(from) {
# 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(.hasSlot(x, "factors") && length(x@factors)) {# drop cashed ones
     if(is(x, "compMatrix") && length(xf <- x@factors)) {  
670          ## instead of dropping all factors, be smart about some          ## instead of dropping all factors, be smart about some
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(.hasSlot(y, "factors") && length(yf <- y@factors)) {
     if(is(y, "compMatrix") && length(yf <- y@factors)) {  
         ## instead of dropping all factors, be smart about some  
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))
# Line 907  Line 918 
918            function(e1,e2) {            function(e1,e2) {
919                n <- e1@Dim[1]                n <- e1@Dim[1]
920                f0 <- callGeneric(0, e2)                f0 <- callGeneric(0, e2)
921                if(all(is0(f0))) { # remain diagonal                if(all0(f0)) { # remain diagonal
922                    L1 <- (le <- length(e2)) == 1L                    L1 <- (le <- length(e2)) == 1L
923                    if(e1@diag == "U") {                    if(e1@diag == "U") {
924                        if(any((r <- callGeneric(1, e2)) != 1)) {                        if(any((r <- callGeneric(1, e2)) != 1)) {
# Line 929  Line 940 
940            function(e1,e2) {            function(e1,e2) {
941                n <- e2@Dim[1]                n <- e2@Dim[1]
942                f0 <- callGeneric(e1, 0)                f0 <- callGeneric(e1, 0)
943                if(all(is0(f0))) { # remain diagonal                if(all0(f0)) { # remain diagonal
944                    L1 <- (le <- length(e1)) == 1L                    L1 <- (le <- length(e1)) == 1L
945                    if(e2@diag == "U") {                    if(e2@diag == "U") {
946                        if(any((r <- callGeneric(e1, 1)) != 1)) {                        if(any((r <- callGeneric(e1, 1)) != 1)) {
# Line 952  Line 963 
963            function(e1,e2) {            function(e1,e2) {
964                n <- e1@Dim[1]                n <- e1@Dim[1]
965                f0 <- callGeneric(0, e2)                f0 <- callGeneric(0, e2)
966                if(all(is0(f0))) { # remain diagonal                if(all0(f0)) { # remain diagonal
967                    L1 <- (le <- length(e2)) == 1L                    L1 <- (le <- length(e2)) == 1L
968                    E <- copyClass(e1, "ddiMatrix", c("diag", "Dim", "Dimnames"))#FIXME: if ok, check=FALSE                    E <- copyClass(e1, "ddiMatrix", c("diag", "Dim", "Dimnames"), check=FALSE)
                   ## E <- copyClass(e1, "ddiMatrix", check=FALSE)  
969                    ## storage.mode(E@x) <- "double"                    ## storage.mode(E@x) <- "double"
970                    if(e1@diag == "U") {                    if(e1@diag == "U") {
971                        if(any((r <- callGeneric(1, e2)) != 1)) {                        if(any((r <- callGeneric(1, e2)) != 1)) {
# Line 977  Line 987 
987            function(e1,e2) {            function(e1,e2) {
988                n <- e2@Dim[1]                n <- e2@Dim[1]
989                f0 <- callGeneric(e1, 0)                f0 <- callGeneric(e1, 0)
990                if(all(is0(f0))) { # remain diagonal                if(all0(f0)) { # remain diagonal
991                    L1 <- (le <- length(e1)) == 1L                    L1 <- (le <- length(e1)) == 1L
992                    E <- copyClass(e2, "ddiMatrix", c("diag", "Dim", "Dimnames"))#FIXME: if ok, check=FALSE                    E <- copyClass(e2, "ddiMatrix", c("diag", "Dim", "Dimnames"), check=FALSE)
                   ## E <- copyClass(e2, "ddiMatrix", check=FALSE)  
993                    ## storage.mode(E@x) <- "double"                    ## storage.mode(E@x) <- "double"
994                    if(e2@diag == "U") {                    if(e2@diag == "U") {
995                        if(any((r <- callGeneric(e1, 1)) != 1)) {                        if(any((r <- callGeneric(e1, 1)) != 1)) {
# Line 1010  Line 1019 
1019            function(e1,e2) {            function(e1,e2) {
1020                n <- e1@Dim[1]                n <- e1@Dim[1]
1021                f0 <- callGeneric(0, e2)                f0 <- callGeneric(0, e2)
1022                if(all(is0(f0))) { # remain diagonal                if(all0(f0)) { # remain diagonal
1023                    L1 <- (le <- length(e2)) == 1L                    L1 <- (le <- length(e2)) == 1L
1024                    E <- copyClass(e1, "ldiMatrix", c("diag", "Dim", "Dimnames"))#FIXME: if ok, check=FALSE                    E <- copyClass(e1, "ldiMatrix", c("diag", "Dim", "Dimnames"), check=FALSE)
                   ## E <- copyClass(e1, "ldiMatrix", check=FALSE)  
1025                    ## storage.mode(E@x) <- "logical"                    ## storage.mode(E@x) <- "logical"
1026                    if(e1@diag == "U") {                    if(e1@diag == "U") {
1027                        if(any((r <- callGeneric(1, e2)) != 1)) {                        if(any((r <- callGeneric(1, e2)) != 1)) {
# Line 1036  Line 1044 
1044            function(e1,e2) {            function(e1,e2) {
1045                n <- e1@Dim[1]                n <- e1@Dim[1]
1046                f0 <- callGeneric(FALSE, e2)                f0 <- callGeneric(FALSE, e2)
1047                if(all(is0(f0))) { # remain diagonal                if(all0(f0)) { # remain diagonal
1048                    L1 <- (le <- length(e2)) == 1L                    L1 <- (le <- length(e2)) == 1L
1049    
1050                    if(e1@diag == "U") {                    if(e1@diag == "U") {

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

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