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 3078, Tue Mar 31 15:27:56 2015 UTC revision 3079, Tue Mar 31 15:29:43 2015 UTC
# Line 658  Line 658 
658  }  }
659  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)  setMethod("%*%", signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)
660    
661  formals(diagmatprod) <- alist(x=, y=NULL, boolArith = NA, ...=)  formals(diagmatprod) <- alist(x=, y=NULL, boolArith = NA, ...=) ## FIXME boolArith
662  setMethod("crossprod",  signature(x = "diagonalMatrix", y = "matrix"), diagmatprod)  diagmatprod2 <- function(x, y=NULL, boolArith = NA, ...) {
663        ## x is diagonalMatrix
664        if(x@Dim[2] != nrow(y)) stop("non-matching dimensions")
665        Matrix(if(x@diag == "U") y else x@x * y)
666    }
667    setMethod("crossprod",  signature(x = "diagonalMatrix", y = "matrix"), diagmatprod2)
668    
669  diagGeprod <- function(x, y) {  diagGeprod <- function(x, y) {
670      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")      if(x@Dim[2] != y@Dim[1]) stop("non-matching dimensions")
# Line 783  Line 788 
788          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])
789          if(isTRUE(boolArith)) {          if(isTRUE(boolArith)) {
790              if(extends(cx, "nMatrix")) x <- as(x, "lMatrix") # so, has y@x              if(extends(cx, "nMatrix")) x <- as(x, "lMatrix") # so, has y@x
791              x@x <- x@x & y@x[x@i + 1L]              x@x <- r <- x@x & y@x[x@i + 1L]
792              if(!extends(cx, "diagonalMatrix")) x <- as(drop0(x), "nMatrix")              if(!anyNA(r) && !extends(cx, "diagonalMatrix")) x <- as(drop0(x), "nMatrix")
793          } else {          } else {
794              if(!extends(cx, "dMatrix")) x <- as(x, "dMatrix") # <- FIXME if we have zMatrix              if(!extends(cx, "dMatrix")) x <- as(x, "dMatrix") # <- FIXME if we have zMatrix
795              x@x <- x@x * y@x[ind]              x@x <- x@x * y@x[ind]
# Line 794  Line 799 
799              ## TODO ......              ## TODO ......
800              x@factors <- list()              x@factors <- list()
801          }          }
     }  
802      x      x
803        } else { #  y is unit-diagonal ==> "return x"
804            cx <- getClass(class(x))
805            if(isTRUE(boolArith)) {
806                is.l <- if(extends(cx, "dMatrix")) { ## <- FIXME: extend once we have iMatrix, zMatrix
807                    x <- as(x, "lMatrix"); TRUE } else extends(cx, "lMatrix")
808                if(is.l && !anyNA(x@x)) as(drop0(x), "nMatrix")
809                else if(is.l) x else # defensive:
810                as(x, "lMatrix")
811            } else {
812                ## else boolArith is  NA or FALSE {which are equivalent here, das diagonal = "numLike"}
813                if(extends(cx, "nMatrix") || extends(cx, "lMatrix"))
814                    as(x, "dMatrix") else x
815            }
816        }
817  }  }
818    
819  ##' @param x diagonalMatrix  ##' @param x diagonalMatrix
# Line 810  Line 828 
828              y <- as(y, "generalMatrix")              y <- as(y, "generalMatrix")
829          if(isTRUE(boolArith)) {          if(isTRUE(boolArith)) {
830              if(extends(cy, "nMatrix")) y <- as(y, "lMatrix") # so, has y@x              if(extends(cy, "nMatrix")) y <- as(y, "lMatrix") # so, has y@x
831              y@x <- y@x & x@x[y@i + 1L]              y@x <- r <- y@x & x@x[y@i + 1L]
832              if(!extends(cy, "diagonalMatrix")) y <- as(drop0(y), "nMatrix")              if(!anyNA(r) && !extends(cy, "diagonalMatrix")) y <- as(drop0(y), "nMatrix")
833          } else {          } else {
834              if(!extends(cy, "dMatrix")) y <- as(y, "dMatrix") # <- FIXME if we have zMatrix              if(!extends(cy, "dMatrix")) y <- as(y, "dMatrix") # <- FIXME if we have zMatrix
835              y@x <- y@x * x@x[y@i + 1L]              y@x <- y@x * x@x[y@i + 1L]
# Line 826  Line 844 
844              ## y@factors <- yf[keep]              ## y@factors <- yf[keep]
845              y@factors <- list()              y@factors <- list()
846          }          }
     }  
847      y      y
848        } else { ## x @ diag  == "U"
849            cy <- getClass(class(y))
850            if(isTRUE(boolArith)) {
851                is.l <- if(extends(cy, "dMatrix")) { ## <- FIXME: extend once we have iMatrix, zMatrix
852                    y <- as(y, "lMatrix"); TRUE } else extends(cy, "lMatrix")
853                if(is.l && !anyNA(y@x)) as(drop0(y), "nMatrix")
854                else if(is.l) y else # defensive:
855                as(y, "lMatrix")
856            } else {
857                ## else boolArith is  NA or FALSE {which are equivalent here, das diagonal = "numLike"}
858                if(extends(cy, "nMatrix") || extends(cy, "lMatrix"))
859                    as(y, "dMatrix") else y
860            }
861        }
862  }  }
863    
864  ## + 'boolArith' argument  { ==> .local() is used in any case; keep formals simple :}  ## + 'boolArith' argument  { ==> .local() is used in any case; keep formals simple :}

Legend:
Removed from v.3078  
changed lines
  Added in v.3079

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