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 2811, Mon Jul 16 15:50:31 2012 UTC revision 2813, Wed Jul 18 16:02:38 2012 UTC
# Line 86  Line 86 
86  .bdiag <- function(lst) {  .bdiag <- function(lst) {
87      ## block-diagonal matrix [a dgTMatrix] from list of matrices      ## block-diagonal matrix [a dgTMatrix] from list of matrices
88      stopifnot(is.list(lst), length(lst) >= 1)      stopifnot(is.list(lst), length(lst) >= 1)
89      dims <- sapply(lst, dim, USE.NAMES=FALSE)      dims <- vapply(lst, dim, 1L, USE.NAMES=FALSE)
90      ## make sure we had all matrices:      ## make sure we had all matrices:
91      if(!(is.matrix(dims) && nrow(dims) == 2))      if(!(is.matrix(dims) && nrow(dims) == 2))
92          stop("some arguments are not matrices")          stop("some arguments are not matrices")
# Line 115  Line 115 
115                     as, "TsparseMatrix")                     as, "TsparseMatrix")
116      if(nl == 1) return(Tlst[[1]])      if(nl == 1) return(Tlst[[1]])
117      ## else      ## else
118      i_off <- c(0L, cumsum(sapply(Tlst, nrow)))      i_off <- c(0L, cumsum(vapply(Tlst, nrow, 1L)))
119      j_off <- c(0L, cumsum(sapply(Tlst, ncol)))      j_off <- c(0L, cumsum(vapply(Tlst, ncol, 1L)))
120    
121      clss <- sapply(Tlst, class)      clss <- vapply(Tlst, class, "")
122      typ <- substr(clss, 2, 2)      typ <- substr(clss, 2, 2)
123      knd <- substr(clss, 1, 1)      knd <- substr(clss, 1, 1)
124      sym <- typ == "s" # symmetric ones      sym <- typ == "s" # symmetric ones
# Line 130  Line 130 
130      }      }
131      use.l <- !use.n && all(knd == "l")      use.l <- !use.n && all(knd == "l")
132      if(all(sym)) { ## result should be *symmetric*      if(all(sym)) { ## result should be *symmetric*
133          uplos <- sapply(Tlst, slot, "uplo") ## either "U" or "L"          uplos <- vapply(Tlst, slot, ".", "uplo") ## either "U" or "L"
134          tLU <- table(uplos)# of length 1 or 2 ..          tLU <- table(uplos)# of length 1 or 2 ..
135          if(length(tLU) == 1) { ## all "U" or all "L"          if(length(tLU) == 1) { ## all "U" or all "L"
136              useU <- uplos[1] == "U"              useU <- uplos[1] == "U"
# Line 149  Line 149 
149          }          }
150          r@uplo <- if(useU) "U" else "L"          r@uplo <- if(useU) "U" else "L"
151      }      }
152      else if(all(tri) && { ULs <- sapply(Tlst, slot, "uplo")##  "U" or "L"      else if(all(tri) && { ULs <- vapply(Tlst, slot, ".", "uplo")##  "U" or "L"
153                            all(ULs[1L] == ULs[-1L]) } ## all upper or all lower                            all(ULs[1L] == ULs[-1L]) } ## all upper or all lower
154         ){ ## *triangular* result         ){ ## *triangular* result
155    
# Line 864  Line 864 
864    
865  ##  other = "numeric" : stay diagonal if possible  ##  other = "numeric" : stay diagonal if possible
866  ## ddi*: Arith: result numeric, potentially ddiMatrix  ## ddi*: Arith: result numeric, potentially ddiMatrix
867  setMethod("Arith", signature(e1 = "ddiMatrix", e2 = "numeric"),  for(arg2 in c("numeric","logical"))
868    setMethod("Arith", signature(e1 = "ddiMatrix", e2 = arg2),
869            function(e1,e2) {            function(e1,e2) {
870                n <- e1@Dim[1]; nsq <- n^2                n <- e1@Dim[1]; nsq <- n^2
871                f0 <- callGeneric(0, e2)                f0 <- callGeneric(0, e2)
# Line 882  Line 883 
883                callGeneric(diag2tT.u(e1,e2, "d"), e2)                callGeneric(diag2tT.u(e1,e2, "d"), e2)
884            })            })
885    
886  setMethod("Arith", signature(e1 = "numeric", e2 = "ddiMatrix"),  for(arg1 in c("numeric","logical"))
887    setMethod("Arith", signature(e1 = arg1, e2 = "ddiMatrix"),
888            function(e1,e2) {            function(e1,e2) {
889                n <- e2@Dim[1]; nsq <- n^2                n <- e2@Dim[1]; nsq <- n^2
890                f0 <- callGeneric(e1, 0)                f0 <- callGeneric(e1, 0)
# Line 901  Line 903 
903            })            })
904    
905  ## ldi* Arith --> result numeric, potentially ddiMatrix  ## ldi* Arith --> result numeric, potentially ddiMatrix
906  setMethod("Arith", signature(e1 = "ldiMatrix", e2 = "numeric"),  for(arg2 in c("numeric","logical"))
907    setMethod("Arith", signature(e1 = "ldiMatrix", e2 = arg2),
908            function(e1,e2) {            function(e1,e2) {
909                n <- e1@Dim[1]; nsq <- n^2                n <- e1@Dim[1]; nsq <- n^2
910                f0 <- callGeneric(0, e2)                f0 <- callGeneric(0, e2)
# Line 917  Line 920 
920                    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))]
921                    return(e1)                    return(e1)
922                }                }
923                callGeneric(diag2tT.u(e1,e2, "d"), e2)                callGeneric(diag2tT.u(e1,e2, "l"), e2)
924            })            })
925    
926  setMethod("Arith", signature(e1 = "numeric", e2 = "ldiMatrix"),  for(arg1 in c("numeric","logical"))
927    setMethod("Arith", signature(e1 = arg1, e2 = "ldiMatrix"),
928            function(e1,e2) {            function(e1,e2) {
929                n <- e2@Dim[1]; nsq <- n^2                n <- e2@Dim[1]; nsq <- n^2
930                f0 <- callGeneric(e1, 0)                f0 <- callGeneric(e1, 0)
# Line 936  Line 940 
940                    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))]
941                    return(e2)                    return(e2)
942                }                }
943                callGeneric(e1, diag2tT.u(e2,e1, "d"))                callGeneric(e1, diag2tT.u(e2,e1, "l"))
944            })            })
945    
946  ## ddi*: for "Ops" without Arith --> result logical, potentially ldi  ## ddi*: for "Ops" without Arith --> result logical, potentially ldi
947  setMethod("Ops", signature(e1 = "ddiMatrix", e2 = "numeric"),  for(arg2 in c("numeric","logical"))
948    setMethod("Ops", signature(e1 = "ddiMatrix", e2 = arg2),
949            function(e1,e2) {            function(e1,e2) {
950                n <- e1@Dim[1]; nsq <- n^2                n <- e1@Dim[1]; nsq <- n^2
951                f0 <- callGeneric(0, e2)                f0 <- callGeneric(0, e2)
# Line 956  Line 961 
961                    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))]
962                    return(e1)                    return(e1)
963                }                }
964                callGeneric(diag2tT.u(e1,e2, "l"), e2)                callGeneric(diag2tT.u(e1,e2, "d"), e2)
965            })            })
966    
967  setMethod("Ops", signature(e1 = "numeric", e2 = "ddiMatrix"),  for(arg1 in c("numeric","logical"))
968    setMethod("Ops", signature(e1 = arg1, e2 = "ddiMatrix"),
969            function(e1,e2) {            function(e1,e2) {
970                n <- e2@Dim[1]; nsq <- n^2                n <- e2@Dim[1]; nsq <- n^2
971                f0 <- callGeneric(e1, 0)                f0 <- callGeneric(e1, 0)
# Line 975  Line 981 
981                    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))]
982                    return(e2)                    return(e2)
983                }                }
984                callGeneric(e1, diag2tT.u(e2,e1, "l"))                callGeneric(e1, diag2tT.u(e2,e1, "d"))
985            })            })
986    
987  ## ldi*: for "Ops" without Arith --> result logical, potentially ldi  ## ldi*: for "Ops" without Arith --> result logical, potentially ldi
988  setMethod("Ops", signature(e1 = "ldiMatrix", e2 = "numeric"),  for(arg2 in c("numeric","logical"))
989    setMethod("Ops", signature(e1 = "ldiMatrix", e2 = arg2),
990            function(e1,e2) {            function(e1,e2) {
991                n <- e1@Dim[1]; nsq <- n^2                n <- e1@Dim[1]; nsq <- n^2
992                f0 <- callGeneric(FALSE, e2)                f0 <- callGeneric(FALSE, e2)
# Line 997  Line 1004 
1004                callGeneric(diag2tT.u(e1,e2, "l"), e2)                callGeneric(diag2tT.u(e1,e2, "l"), e2)
1005            })            })
1006    
1007  setMethod("Ops", signature(e1 = "numeric", e2 = "ldiMatrix"),  for(arg1 in c("numeric","logical"))
1008    setMethod("Ops", signature(e1 = arg1, e2 = "ldiMatrix"),
1009            function(e1,e2) {            function(e1,e2) {
1010                n <- e2@Dim[1]; nsq <- n^2                n <- e2@Dim[1]; nsq <- n^2
1011                f0 <- callGeneric(e1, FALSE)                f0 <- callGeneric(e1, FALSE)
# Line 1032  Line 1040 
1040  }  }
1041    
1042  ## Direct subclasses of "denseMatrix": currently ddenseMatrix, ldense... :  ## Direct subclasses of "denseMatrix": currently ddenseMatrix, ldense... :
 if(FALSE)## too general, would contain  denseModelMatrix:  
1043  dense.subCl <- local({ dM.scl <- getClass("denseMatrix")@subclasses  dense.subCl <- local({ dM.scl <- getClass("denseMatrix")@subclasses
1044                         names(dM.scl)[sapply(dM.scl, slot, "distance") == 1] })                         names(dM.scl)[vapply(dM.scl, slot, 0, "distance") == 1] })
 dense.subCl <- paste(c("d","l","n"), "denseMatrix", sep="")  
1045  for(DI in diCls) {  for(DI in diCls) {
1046      for(c2 in c(dense.subCl, "Matrix")) {      for(c2 in c(dense.subCl, "Matrix")) {
1047          for(Fun in c("*", "^", "&")) {          for(Fun in c("*", "^", "&")) {
# Line 1130  Line 1136 
1136                    invisible(object)                    invisible(object)
1137                }                }
1138            })            })
1139    
1140    rm(dense.subCl, diCls)# not used elsewhere

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

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