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 2052, Wed Aug 15 13:33:19 2007 UTC revision 2112, Mon Feb 18 08:24:46 2008 UTC
# Line 94  Line 94 
94                 nrow = n, ncol = n)                 nrow = n, ncol = n)
95        })        })
96    
97    setMethod("as.vector", signature(x = "diagonalMatrix", mode="missing"),
98              function(x, mode) {
99                  n <- x@Dim[1]
100                  mod <- mode(x@x)
101                  r <- vector(mod, length = n^2)
102                  if(n)
103                      r[1 + 0:(n - 1) * (n + 1)] <-
104                          if(x@diag == "U")
105                              switch(mod, "integer"= 1L,
106                                     "numeric"= 1, "logical"= TRUE)
107                          else x@x
108                  r
109              })
110    
111  setAs("diagonalMatrix", "generalMatrix", # prefer sparse:  setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
112        function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))        function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))
113    
# Line 189  Line 203 
203            function(x = 1, nrow, ncol) .diag.x(x))            function(x = 1, nrow, ncol) .diag.x(x))
204    
205    
206  subDiag <- function(x, i, j, drop) {  subDiag <- function(x, i, j, ..., drop) {
207      x <- as(x, "sparseMatrix")      x <- as(x, "sparseMatrix")
208      x <- if(missing(i))      x <- if(missing(i))
209          x[, j, drop=drop]          x[, j, drop=drop]
# Line 204  Line 218 
218                           j = "index", drop = "logical"), subDiag)                           j = "index", drop = "logical"), subDiag)
219  setMethod("[", signature(x = "diagonalMatrix", i = "index",  setMethod("[", signature(x = "diagonalMatrix", i = "index",
220                          j = "missing", drop = "logical"),                          j = "missing", drop = "logical"),
221            function(x, i, drop) subDiag(x, i=i, drop=drop))            function(x, i, j, ..., drop) subDiag(x, i=i, drop=drop))
222  setMethod("[", signature(x = "diagonalMatrix", i = "missing",  setMethod("[", signature(x = "diagonalMatrix", i = "missing",
223                           j = "index", drop = "logical"),                           j = "index", drop = "logical"),
224            function(x, j, drop) subDiag(x, j=j, drop=drop))            function(x, i, j, ..., drop) subDiag(x, j=j, drop=drop))
225    
226  ## When you assign to a diagonalMatrix, the result should be  ## When you assign to a diagonalMatrix, the result should be
227  ## diagonal or sparse ---  ## diagonal or sparse ---
228  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch  ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
229  replDiag <- function(x, i, j, value) {  ## Only(?) current bug:  x[i] <- value  is wrong when  i is *vector*
230    replDiag <- function(x, i, j, ..., value) {
231      x <- as(x, "sparseMatrix")      x <- as(x, "sparseMatrix")
232      if(missing(i))      if(missing(i))
233          x[, j] <- value          x[, j] <- value
234      else if(missing(j))      else if(missing(j)) { ##  x[i , ] <- v  *OR*   x[i] <- v
235            na <- nargs()
236    ##         message("diagnosing replDiag() -- nargs()= ", na)
237            if(na == 4)
238          x[i, ] <- value          x[i, ] <- value
239      else          else if(na == 3)
240                x[i] <- value
241            else stop("Internal bug: nargs()=",na,"; please report")
242        } else
243          x[i,j] <- value          x[i,j] <- value
244      if(isDiagonal(x)) as(x, "diagonalMatrix") else x      if(isDiagonal(x)) as(x, "diagonalMatrix") else x
245  }  }
246    
247  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
248                                  j = "index", value = "replValue"), replDiag)                                  j = "index", value = "replValue"), replDiag)
249    
250  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
251                                  j = "missing", value = "replValue"),                                  j = "missing", value = "replValue"),
252                   function(x, i, value) replDiag(x, i=i, value=value))                   function(x,i,j, ..., value) {
253                         ## message("before replDiag() -- nargs()= ", nargs())
254                         if(nargs() == 3)
255                             replDiag(x, i=i, value=value)
256                         else ## nargs() == 4 :
257                             replDiag(x, i=i, , value=value)
258                     })
259    
260    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "matrix", # 2-col.matrix
261                                    j = "missing", value = "replValue"),
262                     function(x,i,j, ..., value) {
263                         if(ncol(i) == 2) {
264                             if(all((ii <- i[,1]) == i[,2])) { # replace in diagonal only
265                                 x@x[ii] <- value
266                                 x
267                             } else { ## no longer diagonal, but remain sparse:
268                                 x <- as(x, "sparseMatrix")
269                                 x[i] <- value
270                                 x
271                             }
272                         }
273                         else { # behave as "base R": use as if vector
274                             x <- as(x, "matrix")
275                             x[i] <- value
276                             Matrix(x)
277                         }
278                     })
279    
280  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing",  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing",
281                                  j = "index", value = "replValue"),                                  j = "index", value = "replValue"),
282                   function(x, j, value) replDiag(x, j=j, value=value))                   function(x,i,j, ..., value) replDiag(x, j=j, value=value))
283    
284    
285  setMethod("t", signature(x = "diagonalMatrix"),  setMethod("t", signature(x = "diagonalMatrix"),
# Line 241  Line 290 
290  setMethod("isTriangular", signature(object = "diagonalMatrix"),  setMethod("isTriangular", signature(object = "diagonalMatrix"),
291            function(object) TRUE)            function(object) TRUE)
292  setMethod("isSymmetric", signature(object = "diagonalMatrix"),  setMethod("isSymmetric", signature(object = "diagonalMatrix"),
293            function(object) TRUE)            function(object, ...) TRUE)
294    
295    setMethod("symmpart", signature(x = "diagonalMatrix"), function(x) x)
296    setMethod("skewpart", signature(x = "diagonalMatrix"), setZero)
297    
298  setMethod("chol", signature(x = "ddiMatrix"),# pivot = "ANY"  setMethod("chol", signature(x = "ddiMatrix"),# pivot = "ANY"
299            function(x, pivot) {            function(x, pivot) {
# Line 395  Line 447 
447  setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),  setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
448            solveDiag)            solveDiag)
449    
450    ## Schur()  ---> ./eigen.R
451    
452    
453    

Legend:
Removed from v.2052  
changed lines
  Added in v.2112

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