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 1174, Mon Jan 16 20:03:48 2006 UTC revision 2052, Wed Aug 15 13:33:19 2007 UTC
# Line 1  Line 1 
1    #### All methods for "diagonalMatrix" and its subclasses,
2    ####  currently "ddiMatrix", "ldiMatrix"
3    
4  ## Purpose: Constructor of diagonal matrices -- ~= diag() ,  ## Purpose: Constructor of diagonal matrices -- ~= diag() ,
5  ##          but *not* diag() extractor!  ##          but *not* diag() extractor!
6  Diagonal <- function(n, x = NULL)  Diagonal <- function(n, x = NULL)
# Line 10  Line 13 
13          n <- as.integer(n)          n <- as.integer(n)
14      }      }
15    
16      if(missing(x)) # unit diagonal matrix      if(missing(x)) ## unit diagonal matrix
17          new("ddiMatrix", Dim = c(n,n), diag = "U")          new("ddiMatrix", Dim = c(n,n), diag = "U")
18      else {      else {
19          stopifnot(length(x) == n)          stopifnot(length(x) == n)
20          if(is.logical(x))          if(is.logical(x))
21              cl <- "ldiMatrix"              cl <- "ldiMatrix"
22          else {          else if(is.numeric(x)) {
23              cl <- "ddiMatrix"              cl <- "ddiMatrix"
24              x <- as.numeric(x)              x <- as.numeric(x)
25          }          }
26            else if(is.complex(x)) {
27                cl <- "zdiMatrix"  # will not yet work
28            } else stop("'x' has invalid data type")
29          new(cl, Dim = c(n,n), diag = "N", x = x)          new(cl, Dim = c(n,n), diag = "N", x = x)
30      }      }
31  }  }
32    
33  setAs("diagonalMatrix", "triangularMatrix",  ### This is modified from a post of Bert Gunter to R-help on  1 Sep 2005.
34        function(from) {  ### Bert's code built on a post by Andy Liaw who most probably was influenced
35            n <- from@Dim[1]  ### by earlier posts, notably one by Scott Chasalow on S-news, 16 Jan 2002
36            i <- seq(length = n)  ### who posted his bdiag() function written in December 1995.
37            x <- from@x  
38            new(if(is.numeric(x)) "dtTMatrix" else "ltTMatrix",  bdiag <- function(...) {
39        if(nargs() == 0) return(new("dgCMatrix"))
40        ## else :
41        mlist <- if (nargs() == 1) as.list(...) else list(...)
42        dims <- sapply(mlist, dim)
43        ## make sure we had all matrices:
44        if(!(is.matrix(dims) && nrow(dims) == 2))
45            stop("some arguments are not matrices")
46        csdim <- rbind(rep.int(0L, 2),
47                       apply(sapply(mlist, dim), 1, cumsum))
48        ret <- new("dgTMatrix", Dim = as.integer(csdim[nrow(csdim),]))
49        add1 <- matrix(1:0, 2,2)
50        for(i in seq_along(mlist)) {
51            indx <- apply(csdim[i:(i+1),] + add1, 2, function(n) n[1]:n[2])
52            if(is.null(dim(indx))) ## non-square matrix
53                ret[indx[[1]],indx[[2]]] <- mlist[[i]]
54            else ## square matrix
55                ret[indx[,1],indx[,2]] <- mlist[[i]]
56        }
57        ## slightly debatable if we really should return Csparse.. :
58        as(ret, "CsparseMatrix")
59    }
60    
61    diag2tT <- function(from) {
62        i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
63        new(paste(.M.kind(from), "tTMatrix", sep=''),
64                diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,                diag = from@diag, Dim = from@Dim, Dimnames = from@Dimnames,
65                x = x, i = i, j = i)          x = from@x, # <- ok for diag = "U" and "N" (!)
66            })          i = i, j = i)
67    }
68    
69    diag2sT <- function(from) { # to symmetric Tsparse
70        i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1L
71        new(paste(.M.kind(from), "sTMatrix", sep=''),
72            Dim = from@Dim, Dimnames = from@Dimnames,
73            x = from@x, i = i, j = i)
74    }
75    
76    setAs("diagonalMatrix", "triangularMatrix", diag2tT)
77    setAs("diagonalMatrix", "sparseMatrix", diag2tT)
78    ## needed too (otherwise <dense> -> Tsparse is taken):
79    setAs("diagonalMatrix", "TsparseMatrix", diag2tT)
80    ## is better than this:
81    ## setAs("diagonalMatrix", "sparseMatrix",
82    ##       function(from)
83    ##        as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
84    setAs("diagonalMatrix", "CsparseMatrix",
85          function(from) as(diag2tT(from), "CsparseMatrix"))
86    
87    setAs("diagonalMatrix", "symmetricMatrix", diag2sT)
88    
89  setAs("diagonalMatrix", "matrix",  setAs("diagonalMatrix", "matrix",
90        function(from) {        function(from) {
# Line 43  Line 94 
94                 nrow = n, ncol = n)                 nrow = n, ncol = n)
95        })        })
96    
97  setAs("diagonalMatrix", "generalMatrix",  setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
98          function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))
99    
100    .diag.x <- function(m) {
101        if(m@diag == "U")
102            rep.int(if(is.numeric(m@x)) 1. else TRUE,
103                    m@Dim[1])
104        else m@x
105    }
106    
107    .diag.2N <- function(m) {
108        if(m@diag == "U") m@diag <- "N"
109        m
110    }
111    
112    ## given the above, the following  4  coercions should be all unneeded;
113    ## we prefer triangular to general:
114    setAs("ddiMatrix", "dgTMatrix",
115        function(from) {        function(from) {
116            x <- as(from, "matrix")            .Deprecated("as(, \"sparseMatrix\")")
117            as(x,            n <- from@Dim[1]
118               if(is.logical(x)) "lgeMatrix"            i <- seq_len(n) - 1L
119  ## Not yet:            new("dgTMatrix", i = i, j = i, x = .diag.x(from),
120  ##              else if(is.complex(x)) "zgeMatrix"                Dim = c(n,n), Dimnames = from@Dimnames) })
121  ##              else if(is.integer(x)) "igeMatrix"  
122               else "dgeMatrix")  setAs("ddiMatrix", "dgCMatrix",
123        })        function(from) as(as(from, "sparseMatrix"), "dgCMatrix"))
124    
125    setAs("ldiMatrix", "lgTMatrix",
126          function(from) {
127              .Deprecated("as(, \"sparseMatrix\")")
128              n <- from@Dim[1]
129              if(from@diag == "U") { # unit-diagonal
130                  x <- rep.int(TRUE, n)
131                  i <- seq_len(n) - 1L
132              } else { # "normal"
133                  nz <- nz.NA(from@x, na. = TRUE)
134                  x <- from@x[nz]
135                  i <- which(nz) - 1L
136              }
137              new("lgTMatrix", i = i, j = i, x = x,
138                  Dim = c(n,n), Dimnames = from@Dimnames) })
139    
140    setAs("ldiMatrix", "lgCMatrix",
141          function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
142    
143    
144    if(FALSE) # now have faster  "ddense" -> "dge"
145  setAs("ddiMatrix", "dgeMatrix",  setAs("ddiMatrix", "dgeMatrix",
146        function(from) as(as(from, "matrix"), "dgeMatrix"))        function(from) as(as(from, "matrix"), "dgeMatrix"))
147    
   
148  setAs("matrix", "diagonalMatrix",  setAs("matrix", "diagonalMatrix",
149        function(from) {        function(from) {
150            d <- dim(from)            d <- dim(from)
# Line 72  Line 159 
159                cl <- "ddiMatrix"                cl <- "ddiMatrix"
160                uni <- all(x == 1)                uni <- all(x == 1)
161                storage.mode(x) <- "double"                storage.mode(x) <- "double"
162            }            } ## TODO: complex
163            new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",            new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
164                x = if(uni) x[FALSE] else x)                x = if(uni) x[FALSE] else x)
165        })        })
# Line 97  Line 184 
184                x = if(uni) x[FALSE] else x)                x = if(uni) x[FALSE] else x)
185        })        })
186    
187    
188    setMethod("diag", signature(x = "diagonalMatrix"),
189              function(x = 1, nrow, ncol) .diag.x(x))
190    
191    
192    subDiag <- function(x, i, j, drop) {
193        x <- as(x, "sparseMatrix")
194        x <- if(missing(i))
195            x[, j, drop=drop]
196        else if(missing(j))
197            x[i, , drop=drop]
198        else
199            x[i,j, drop=drop]
200        if(isDiagonal(x)) as(x, "diagonalMatrix") else x
201    }
202    
203    setMethod("[", signature(x = "diagonalMatrix", i = "index",
204                             j = "index", drop = "logical"), subDiag)
205    setMethod("[", signature(x = "diagonalMatrix", i = "index",
206                            j = "missing", drop = "logical"),
207              function(x, i, drop) subDiag(x, i=i, drop=drop))
208    setMethod("[", signature(x = "diagonalMatrix", i = "missing",
209                             j = "index", drop = "logical"),
210              function(x, j, drop) subDiag(x, j=j, drop=drop))
211    
212    ## When you assign to a diagonalMatrix, the result should be
213    ## diagonal or sparse ---
214    ## FIXME: this now fails because the "denseMatrix" methods come first in dispatch
215    replDiag <- function(x, i, j, value) {
216        x <- as(x, "sparseMatrix")
217        if(missing(i))
218            x[, j] <- value
219        else if(missing(j))
220            x[i, ] <- value
221        else
222            x[i,j] <- value
223        if(isDiagonal(x)) as(x, "diagonalMatrix") else x
224    }
225    
226    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
227                                    j = "index", value = "replValue"), replDiag)
228    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "index",
229                                    j = "missing", value = "replValue"),
230                     function(x, i, value) replDiag(x, i=i, value=value))
231    setReplaceMethod("[", signature(x = "diagonalMatrix", i = "missing",
232                                    j = "index", value = "replValue"),
233                     function(x, j, value) replDiag(x, j=j, value=value))
234    
235    
236  setMethod("t", signature(x = "diagonalMatrix"),  setMethod("t", signature(x = "diagonalMatrix"),
237            function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })            function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })
238    
239    setMethod("isDiagonal", signature(object = "diagonalMatrix"),
240              function(object) TRUE)
241    setMethod("isTriangular", signature(object = "diagonalMatrix"),
242              function(object) TRUE)
243  setMethod("isSymmetric", signature(object = "diagonalMatrix"),  setMethod("isSymmetric", signature(object = "diagonalMatrix"),
244            function(object) TRUE)            function(object) TRUE)
245    
246  setMethod("diag", signature(x = "diagonalMatrix"),  setMethod("chol", signature(x = "ddiMatrix"),# pivot = "ANY"
247            function(x = 1, nrow, ncol = n) {            function(x, pivot) {
248               if(x@diag == "U")                if(any(x@x < 0)) stop("chol() is undefined for diagonal matrix with negative entries")
249                   rep.int(if(is.logical(x@x)) TRUE else 1, x@Dim[1])                x@x <- sqrt(x@x)
              else x@x  
           })  
   
 setMethod("!", "ldiMatrix", function(e1) {  
     if(e1@diag == "N")  
         e1@x <- !e1@x  
     else { ## "U"  
         e1@diag <- "N"  
         e1@x <- rep.int(FALSE, e1@Dim[1])  
     }  
250      x      x
251  })  })
252    ## chol(L) is L for logical diagonal:
253    setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)
254    
255  ## Basic Matrix Multiplication {many more to add}  ## Basic Matrix Multiplication {many more to add}
256    ##       ---------------------
257  ## FIXME: extend this for 'ldi', i.e. do "diagonalMatrix"  ## Note that "ldi" logical are treated as numeric
258  diagdiagprod <- function(x, y) {  diagdiagprod <- function(x, y) {
259      if(any(dim(x) != dim(y))) stop("non-matching dimensions")      if(any(dim(x) != dim(y))) stop("non-matching dimensions")
260      if(x@diag != "U") {      if(x@diag != "U") {
261          if(y@diag != "U") x@x <- x@x * y@x          if(y@diag != "U") {
262                nx <- x@x * y@x
263                if(is.numeric(nx) && !is.numeric(x@x))
264                    x <- as(x, "dMatrix")
265                x@x <- as.numeric(nx)
266            }
267          return(x)          return(x)
268      } else ## x is unit diagonal      } else ## x is unit diagonal
269      return(y)      return(y)
270  }  }
271    
272  setMethod("%*%", signature(x = "ddiMatrix", y = "ddiMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
273            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
274    
275  formals(diagdiagprod) <- alist(x=, y=NULL)  formals(diagdiagprod) <- alist(x=, y=x)
276  setMethod("crossprod", signature(x = "ddiMatrix", y = "ddiMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
277            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
278  setMethod("tcrossprod", signature(x = "ddiMatrix", y = "ddiMatrix"),  setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
279              diagdiagprod, valueClass = "ddiMatrix")
280    setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),
281              diagdiagprod, valueClass = "ddiMatrix")
282    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),
283            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
284    
285    
# Line 155  Line 296 
296  formals(diagmatprod) <- alist(x=, y=NULL)  formals(diagmatprod) <- alist(x=, y=NULL)
297  setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),
298            diagmatprod)            diagmatprod)
299    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "matrix"),
300              diagmatprod)
301    
302  diagdgeprod <- function(x, y) {  diagdgeprod <- function(x, y) {
303      dx <- dim(x)      dx <- dim(x)
# Line 175  Line 318 
318                dx <- dim(x)                dx <- dim(x)
319                dy <- dim(y)                dy <- dim(y)
320                if(dx[2] != dy[1]) stop("non-matching dimensions")                if(dx[2] != dy[1]) stop("non-matching dimensions")
321                as(if(y@diag == "U") x else x * rep.int(y@x, dx[1]), "Matrix")                as(if(y@diag == "U") x else x * rep(y@x, each = dx[1]), "Matrix")
322            })            })
323    
324  setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),
# Line 184  Line 327 
327                dy <- dim(y)                dy <- dim(y)
328                if(dx[2] != dy[1]) stop("non-matching dimensions")                if(dx[2] != dy[1]) stop("non-matching dimensions")
329                if(y@diag == "N")                if(y@diag == "N")
330                    x@x <- x@x * rep.int(y@x, dx[1])                    x@x <- x@x * rep(y@x, each = dx[1])
331                x                x
332            })            })
333    
334  ## crossprod  ## crossprod {more of these}
335    
336    ## tcrossprod --- all are not yet there: do the dense ones here:
337    
338    ## FIXME:
339    ## setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "denseMatrix"),
340    ##        function(x, y = NULL) {
341    ##           })
342    
343    ## setMethod("tcrossprod", signature(x = "denseMatrix", y = "diagonalMatrix"),
344    ##        function(x, y = NULL) {
345    ##           })
346    
347    setMethod("crossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
348              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
349    
350    setMethod("crossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
351              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
352    
353    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "sparseMatrix"),
354              function(x, y = NULL) { x <- as(x, "sparseMatrix"); callGeneric() })
355    
356    setMethod("tcrossprod", signature(x = "sparseMatrix", y = "diagonalMatrix"),
357              function(x, y = NULL) { y <- as(y, "sparseMatrix"); callGeneric() })
358    
359    
360    ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
361    setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
362              function(x, y) as(x, "sparseMatrix") %*% y)
363    ## NB: The previous is *not* triggering for  "ddi" o "dgC" (= distance 3)
364    ##     since there's a "ddense" o "Csparse" at dist. 2 => triggers first.
365    ## ==> do this:
366    setMethod("%*%", signature(x = "diagonalMatrix", y = "CsparseMatrix"),
367              function(x, y) as(x, "CsparseMatrix") %*% y)
368    setMethod("%*%", signature(x = "CsparseMatrix", y = "diagonalMatrix"),
369              function(x, y) x %*% as(y, "CsparseMatrix"))
370    ## NB: this is *not* needed for Tsparse & Rsparse
371    ## TODO: Write tests in ./tests/ which ensure that many "ops" with diagonal*
372    ##       do indeed work by going through sparse (and *not* ddense)!
373    
374    setMethod("%*%", signature(x = "sparseMatrix", y = "diagonalMatrix"),
375              function(x, y) x %*% as(y, "sparseMatrix"))
376    
377    
378    setMethod("solve", signature(a = "diagonalMatrix", b = "missing"),
379              function(a, b, ...) {
380                  a@x <- 1/ a@x
381                  a@Dimnames <- a@Dimnames[2:1]
382                  a
383              })
384    
385    solveDiag <- function(a, b, ...) {
386        if((n <- a@Dim[1]) != nrow(b))
387            stop("incompatible matrix dimensions")
388        ## trivially invert a 'in place' and multiply:
389        a@x <- 1/ a@x
390        a@Dimnames <- a@Dimnames[2:1]
391        a %*% b
392    }
393    setMethod("solve", signature(a = "diagonalMatrix", b = "matrix"),
394              solveDiag)
395    setMethod("solve", signature(a = "diagonalMatrix", b = "Matrix"),
396              solveDiag)
397    
398    
399    
400    
401  ## tcrossprod  ### ---------------- diagonal  o  sparse  -----------------------------
402    
403    
404    ## Use function for several signatures, in order to evade
405    ## ambiguous dispatch for "ddi", since there's also Arith(ddense., ddense.)
406    diagOdiag <- function(e1,e2) { # result should also be diagonal
407        r <- callGeneric(.diag.x(e1), .diag.x(e2)) # error if not "compatible"
408        if(is.numeric(r)) {
409            if(is.numeric(e2@x)) {
410                e2@x <- r; return(.diag.2N(e2)) }
411            if(!is.numeric(e1@x))
412                ## e.g. e1, e2 are logical;
413                e1 <- as(e1, "dMatrix")
414        }
415        else if(is.logical(r))
416            e1 <- as(e1, "lMatrix")
417        else stop("intermediate 'r' is of type", typeof(r))
418        e1@x <- r
419        .diag.2N(e1)
420    }
421    
422    setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "diagonalMatrix"),
423              diagOdiag)
424    ## These two are just for method disambiguation:
425    setMethod("Ops", signature(e1 = "ddiMatrix", e2 = "diagonalMatrix"),
426              diagOdiag)
427    setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ddiMatrix"),
428              diagOdiag)
429    
430    ## FIXME:    diagonal  o  triangular  |-->  triangular
431    ## -----     diagonal  o  symmetric   |-->  symmetric
432    ##    {also when other is sparse: do these "here" --
433    ##     before conversion to sparse, since that loses "diagonality"}
434    
435    ## For almost everything else, diag* shall be treated "as sparse" :
436    ## These are cheap implementations via coercion
437    
438    ## for disambiguation
439    setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),
440              function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))
441    setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),
442              function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))
443    ## in general:
444    setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "ANY"),
445              function(e1,e2) callGeneric(as(e1,"sparseMatrix"), e2))
446    setMethod("Ops", signature(e1 = "ANY", e2 = "diagonalMatrix"),
447              function(e1,e2) callGeneric(e1, as(e2,"sparseMatrix")))
448    
449    
450    
451  ## similar to prTriang() in ./Auxiliaries.R :  ## similar to prTriang() in ./Auxiliaries.R :
# Line 206  Line 460 
460  }  }
461    
462  setMethod("show", signature(object = "diagonalMatrix"),  setMethod("show", signature(object = "diagonalMatrix"),
463            function(object) prDiag(object))            function(object) {
464                  d <- dim(object)
465                  cl <- class(object)
466                  cat(sprintf('%d x %d diagonal matrix of class "%s"\n',
467                              d[1], d[2], cl))
468                  prDiag(object)
469              })

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

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