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 2096, Fri Dec 7 17:44:44 2007 UTC revision 2098, Sun Dec 9 00:35:14 2007 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")
     message(sprintf("diagnosing replDiag() -- nargs() = %d\n", nargs()))  
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  setReplaceMethod("[", signature(x = "diagonalMatrix", i = "matrix", # 2-col.matrix
261                                  j = "missing", value = "replValue"),                                  j = "missing", value = "replValue"),
262                   function(x, i, value) {                   function(x,i,j, ..., value) {
263                       if(ncol(i) == 2) {                       if(ncol(i) == 2) {
264                           if(all((ii <- i[,1]) == i[,2])) { # replace in diagonal only                           if(all((ii <- i[,1]) == i[,2])) { # replace in diagonal only
265                               x@x[ii] <- value                               x@x[ii] <- value
# Line 251  Line 279 
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"),

Legend:
Removed from v.2096  
changed lines
  Added in v.2098

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