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 2813, Wed Jul 18 16:02:38 2012 UTC revision 2814, Tue Jul 24 14:02:28 2012 UTC
# Line 229  Line 229 
229          .diag2tT(d, uplo = if(extends(clx,"triangularMatrix")) x@uplo else "U", kind)          .diag2tT(d, uplo = if(extends(clx,"triangularMatrix")) x@uplo else "U", kind)
230  }  }
231    
232    ## FIXME: should not be needed {when ddi* is dsparse* etc}:
233    setMethod("is.finite", signature(x = "diagonalMatrix"),
234              function(x) is.finite(.diag2tT(x)))
235    setMethod("is.infinite", signature(x = "diagonalMatrix"),
236              function(x) is.infinite(.diag2tT(x)))
237    
238  ## In order to evade method dispatch ambiguity warnings,  ## In order to evade method dispatch ambiguity warnings,
239  ## and because we can save a .M.kind() call, we use this explicit  ## and because we can save a .M.kind() call, we use this explicit
# Line 733  Line 738 
738      r00 <- callGeneric(if(is.numeric(e1@x)) 0 else FALSE,      r00 <- callGeneric(if(is.numeric(e1@x)) 0 else FALSE,
739                         if(is.numeric(e2@x)) 0 else FALSE)                         if(is.numeric(e2@x)) 0 else FALSE)
740      if(is0(r00)) { ##  r00 == 0 or FALSE --- result *is* diagonal      if(is0(r00)) { ##  r00 == 0 or FALSE --- result *is* diagonal
741          if(is.numeric(r)) {          if(is.numeric(r)) { # "double" *or* "integer"
742              if(is.numeric(e2@x)) {              if(is.numeric(e2@x)) {
743                  e2@x <- r; return(.diag.2N(e2)) }                  e2@x <- r; return(.diag.2N(e2)) }
744              if(!is.numeric(e1@x))              if(!is.numeric(e1@x))
745                  ## e.g. e1, e2 are logical;                  ## e.g. e1, e2 are logical;
746                  e1 <- as(e1, "dMatrix")                  e1 <- as(e1, "dMatrix")
747                if(!is.double(r)) r <- as.double(r)
748          }          }
749          else if(is.logical(r))          else if(is.logical(r))
750              e1 <- as(e1, "lMatrix")              e1 <- as(e1, "lMatrix")
# Line 754  Line 760 
760          d <- e1@Dim          d <- e1@Dim
761          n <- d[1]          n <- d[1]
762          stopifnot(length(r) == n)          stopifnot(length(r) == n)
763            if(isNum && !is.double(r)) r <- as.double(r)
764          xx <- as.vector(matrix(rbind(r, matrix(r00,n,n)), n,n))          xx <- as.vector(matrix(rbind(r, matrix(r00,n,n)), n,n))
765          newcl <-          newcl <-
766              paste0(if(isNum) "d" else if(isLog) {              paste0(if(isNum) "d" else if(isLog) {
# Line 877  Line 884 
884                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
885                    } else                    } else
886                        r <- callGeneric(e1@x, e2)                        r <- callGeneric(e1@x, e2)
887                      if(length(r))
888                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
889                    return(e1)                    return(e1)
890                }                }
# Line 896  Line 904 
904                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
905                    } else                    } else
906                        r <- callGeneric(e1, e2@x)                        r <- callGeneric(e1, e2@x)
907                      if(length(r))
908                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
909                    return(e2)                    return(e2)
910                }                }
# Line 916  Line 925 
925                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
926                    } else                    } else
927                        r <- callGeneric(e1@x, e2)                        r <- callGeneric(e1@x, e2)
928                      ## "future fixme": if we have idiMatrix, and r is 'integer', use idiMatrix
929                    e1 <- copyClass(e1, "ddiMatrix", c("diag", "Dim", "Dimnames"))                    e1 <- copyClass(e1, "ddiMatrix", c("diag", "Dim", "Dimnames"))
930                      if(length(r)) {
931                          if(!is.double(r)) r <- as.double(r)
932                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
933                      }
934                    return(e1)                    return(e1)
935                }                }
936                callGeneric(diag2tT.u(e1,e2, "l"), e2)                callGeneric(diag2tT.u(e1,e2, "l"), e2)
# Line 936  Line 949 
949                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
950                    } else                    } else
951                        r <- callGeneric(e1, e2@x)                        r <- callGeneric(e1, e2@x)
952                      ## "future fixme": if we have idiMatrix, and r is 'integer', use idiMatrix
953                    e2 <- copyClass(e2, "ddiMatrix", c("diag", "Dim", "Dimnames"))                    e2 <- copyClass(e2, "ddiMatrix", c("diag", "Dim", "Dimnames"))
954                      if(length(r)) {
955                          if(!is.double(r)) r <- as.double(r)
956                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
957                      }
958                    return(e2)                    return(e2)
959                }                }
960                callGeneric(e1, diag2tT.u(e2,e1, "l"))                callGeneric(e1, diag2tT.u(e2,e1, "l"))
# Line 958  Line 975 
975                    } else                    } else
976                        r <- callGeneric(e1@x, e2)                        r <- callGeneric(e1@x, e2)
977                    e1 <- copyClass(e1, "ldiMatrix", c("diag", "Dim", "Dimnames"))                    e1 <- copyClass(e1, "ldiMatrix", c("diag", "Dim", "Dimnames"))
978                      if(length(r)) {
979                          if(!is.logical(r)) r <- as.logical(r)
980                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
981                      }
982                    return(e1)                    return(e1)
983                }                }
984                callGeneric(diag2tT.u(e1,e2, "d"), e2)                callGeneric(diag2tT.u(e1,e2, "d"), e2)
# Line 977  Line 997 
997                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
998                    } else                    } else
999                        r <- callGeneric(e1, e2@x)                        r <- callGeneric(e1, e2@x)
1000                      if(length(r)) {
1001                          if(!is.logical(r)) r <- as.logical(r)
1002                    e2 <- copyClass(e2, "ldiMatrix", c("diag", "Dim", "Dimnames"))                    e2 <- copyClass(e2, "ldiMatrix", c("diag", "Dim", "Dimnames"))
1003                      }
1004                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
1005                    return(e2)                    return(e2)
1006                }                }
# Line 998  Line 1021 
1021                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
1022                    } else                    } else
1023                        r <- callGeneric(e1@x, e2)                        r <- callGeneric(e1@x, e2)
1024                      if(length(r))
1025                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e1@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
1026                    return(e1)                    return(e1)
1027                }                }
# Line 1017  Line 1041 
1041                        if(L1) r <- rep.int(r, n)                        if(L1) r <- rep.int(r, n)
1042                    } else                    } else
1043                        r <- callGeneric(e1, e2@x)                        r <- callGeneric(e1, e2@x)
1044                      if(length(r))
1045                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]                    e2@x <- if(L1) r else r[1L + (n+1L)*(0:(n-1L))]
1046                    return(e2)                    return(e2)
1047                }                }
# Line 1043  Line 1068 
1068  dense.subCl <- local({ dM.scl <- getClass("denseMatrix")@subclasses  dense.subCl <- local({ dM.scl <- getClass("denseMatrix")@subclasses
1069                         names(dM.scl)[vapply(dM.scl, slot, 0, "distance") == 1] })                         names(dM.scl)[vapply(dM.scl, slot, 0, "distance") == 1] })
1070  for(DI in diCls) {  for(DI in diCls) {
1071        dMeth <- if(extends(DI, "dMatrix"))
1072            function(e1,e2) callGeneric(diag2Tsmart(e1,e2, "d"), e2)
1073        else # "lMatrix", the only other kind for now
1074            function(e1,e2) callGeneric(diag2Tsmart(e1,e2, "l"), e2)
1075      for(c2 in c(dense.subCl, "Matrix")) {      for(c2 in c(dense.subCl, "Matrix")) {
1076          for(Fun in c("*", "^", "&")) {          for(Fun in c("*", "&")) {
1077              setMethod(Fun, signature(e1 = DI, e2 = c2),              setMethod(Fun, signature(e1 = DI, e2 = c2),
1078                        function(e1,e2) callGeneric(e1, Diagonal(x = diag(e2))))                        function(e1,e2) callGeneric(e1, Diagonal(x = diag(e2))))
1079              setMethod(Fun, signature(e1 = c2, e2 = DI),              setMethod(Fun, signature(e1 = c2, e2 = DI),
1080                        function(e1,e2) callGeneric(Diagonal(x = diag(e1)), e2))                        function(e1,e2) callGeneric(Diagonal(x = diag(e1)), e2))
1081          }          }
1082          ## NB: This arguably implicitly uses  0/0 :== 0  to keep diagonality          setMethod("^", signature(e1 = c2, e2 = DI),
1083          for(Fun in c("%%", "%/%", "/")) {                    function(e1,e2) callGeneric(Diagonal(x = diag(e1)), e2))
1084              setMethod(Fun, signature(e1 = DI, e2 = c2),          for(Fun in c("%%", "%/%", "/")) ## 0 <op> 0 |--> NaN  for these.
1085                        function(e1,e2) callGeneric(e1, Diagonal(x = diag(e2))))              setMethod(Fun, signature(e1 = DI, e2 = c2), dMeth)
         }  
1086      }      }
1087  }  }
1088    

Legend:
Removed from v.2813  
changed lines
  Added in v.2814

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