# SCM Repository

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

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

revision 2674, Fri Jun 10 21:56:20 2011 UTC revision 2741, Fri Dec 9 10:38:51 2011 UTC
# Line 119  Line 119
119      j_off <- c(0L, cumsum(sapply(Tlst, ncol)))      j_off <- c(0L, cumsum(sapply(Tlst, ncol)))
120
121      clss <- sapply(Tlst, class)      clss <- sapply(Tlst, class)
122      knds <- substr(clss, 2, 2)      typ <- substr(clss, 2, 2)
123      sym  <- knds == "s" # symmetric ones      knd <- substr(clss, 1, 1)
124      tri  <- knds == "t" # triangular ones      sym <- typ == "s" # symmetric ones
125      use.n <- any(is.n <- substr(clss,1,1) == "n")      tri <- typ == "t" # triangular ones
126      if(use.n && !(use.n <- all(is.n)))      use.n <- any(is.n <- knd == "n")
127        if(use.n && !(use.n <- all(is.n))) {
128          Tlst[is.n] <- lapply(Tlst[is.n], as, "lMatrix")          Tlst[is.n] <- lapply(Tlst[is.n], as, "lMatrix")
129            knd [is.n] <- "l"
130        }
131        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 <- sapply(Tlst, slot, "uplo") ## either "U" or "L"
134          tLU <- table(uplos)# of length 1 or 2 ..          tLU <- table(uplos)# of length 1 or 2 ..
# Line 140  Line 144
144          if(use.n) { ## return nsparseMatrix :          if(use.n) { ## return nsparseMatrix :
145              r <- new("nsTMatrix")              r <- new("nsTMatrix")
146          } else {          } else {
147              r <- new("dsTMatrix")              r <- new(paste0(if(use.l) "l" else "d", "sTMatrix"))
148              r@x <- unlist(lapply(Tlst, slot, "x"))              r@x <- unlist(lapply(Tlst, slot, "x"))
149          }          }
150          r@uplo <- if(useU) "U" else "L"          r@uplo <- if(useU) "U" else "L"
# Line 152  Line 156
156          if(use.n) { ## return nsparseMatrix :          if(use.n) { ## return nsparseMatrix :
157              r <- new("ntTMatrix")              r <- new("ntTMatrix")
158          } else {          } else {
159              r <- new("dtTMatrix")              r <- new(paste0(if(use.l) "l" else "d", "tTMatrix"))
160              r@x <- unlist(lapply(Tlst, slot, "x"))              r@x <- unlist(lapply(Tlst, slot, "x"))
161          }          }
162          r@uplo <- ULs[1L]          r@uplo <- ULs[1L]
# Line 163  Line 167
167          if(use.n) { ## return nsparseMatrix :          if(use.n) { ## return nsparseMatrix :
168              r <- new("ngTMatrix")              r <- new("ngTMatrix")
169          } else {          } else {
170              r <- new("dgTMatrix")              r <- new(paste0(if(use.l) "l" else "d", "gTMatrix"))
171              r@x <- unlist(lapply(Tlst, slot, "x"))              r@x <- unlist(lapply(Tlst, slot, "x"))
172          }          }
173      }      }

Legend:
 Removed from v.2674 changed lines Added in v.2741

 root@r-forge.r-project.org ViewVC Help Powered by ViewVC 1.0.0
Thanks to: