# SCM Repository

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

# Diff of /pkg/R/diagMatrix.R

revision 1331, Sat Jul 22 17:59:53 2006 UTC revision 1654, Fri Oct 27 16:58:15 2006 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(0:0, 2),
47                       apply(sapply(mlist, dim), 1, cumsum))
48        ret <- new("dgTMatrix", Dim = as.integer(csdim[nrow(csdim),]))
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    diag2T <- function(from) {
62        i <- if(from@diag == "U") integer(0) else seq_len(from@Dim[1]) - 1:1
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    setAs("diagonalMatrix", "triangularMatrix", diag2T)
70    setAs("diagonalMatrix", "sparseMatrix", diag2T)
71    ## is better than this:
72    ## setAs("diagonalMatrix", "sparseMatrix",
73    ##       function(from)
74    ##        as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
75    setAs("diagonalMatrix", "CsparseMatrix",
76          function(from) as(diag2T(from), "CsparseMatrix"))
77
78  setAs("diagonalMatrix", "matrix",  setAs("diagonalMatrix", "matrix",
79        function(from) {        function(from) {
# Line 42  Line 83
83                 nrow = n, ncol = n)                 nrow = n, ncol = n)
84        })        })
85
86  setAs("diagonalMatrix", "generalMatrix",  setAs("diagonalMatrix", "generalMatrix", # prefer sparse:
87        function(from) {        function(from) as(from, paste(.M.kind(from), "gCMatrix", sep='')))
x <- as(from, "matrix")
as(x,
if(is.logical(x)) "lgeMatrix"
## Not yet:
##              else if(is.complex(x)) "zgeMatrix"
##              else if(is.integer(x)) "igeMatrix"
else "dgeMatrix")
})
88
89    ## given the above, the following  4  coercions should be all unneeded;
90    ## we prefer triangular to general:
91  setAs("ddiMatrix", "dgTMatrix",  setAs("ddiMatrix", "dgTMatrix",
92        function(from) {        function(from) {
93              .Deprecated("as(, \"sparseMatrix\")")
94            n <- from@Dim[1]            n <- from@Dim[1]
95            i <- seq(length = n) - 1:1            i <- seq_len(n) - 1:1
96            new("dgTMatrix", i = i, j = i,            new("dgTMatrix", i = i, j = i,
97                x = if(from@diag == "U") rep(1,n) else from@x,                x = if(from@diag == "U") rep(1,n) else from@x,
98                Dim = c(n,n), Dimnames = from@Dimnames) })                Dim = c(n,n), Dimnames = from@Dimnames) })
# Line 66  Line 102
102
103  setAs("ldiMatrix", "lgTMatrix",  setAs("ldiMatrix", "lgTMatrix",
104        function(from) {        function(from) {
105              .Deprecated("as(, \"sparseMatrix\")")
106            n <- from@Dim[1]            n <- from@Dim[1]
107            i <- (if(from@diag == "U") seq(length = n) else which(from@x)) - 1:1            if(from@diag == "U") { # unit-diagonal
108            new("lgTMatrix", i = i, j = i,                x <- rep.int(TRUE, n)
109                  i <- seq_len(n) - 1:1
110              } else { # "normal"
111                  nz <- nz.NA(from@x, na. = TRUE)
112                  x <- from@x[nz]
113                  i <- which(nz) - 1:1
114              }
115              new("lgTMatrix", i = i, j = i, x = x,
116                Dim = c(n,n), Dimnames = from@Dimnames) })                Dim = c(n,n), Dimnames = from@Dimnames) })
117
118  setAs("ldiMatrix", "lgCMatrix",  setAs("ldiMatrix", "lgCMatrix",
119        function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))        function(from) as(as(from, "lgTMatrix"), "lgCMatrix"))
120
setAs("diagonalMatrix", "sparseMatrix",
function(from)
as(from, if(is(from, "dMatrix")) "dgCMatrix" else "lgCMatrix"))
121
122    if(FALSE) # now have faster  "ddense" -> "dge"
123  setAs("ddiMatrix", "dgeMatrix",  setAs("ddiMatrix", "dgeMatrix",
124        function(from) as(as(from, "matrix"), "dgeMatrix"))        function(from) as(as(from, "matrix"), "dgeMatrix"))
125
# Line 95  Line 137
137                cl <- "ddiMatrix"                cl <- "ddiMatrix"
138                uni <- all(x == 1)                uni <- all(x == 1)
139                storage.mode(x) <- "double"                storage.mode(x) <- "double"
140            }            } ## TODO: complex
141            new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",            new(cl, Dim = c(n,n), diag = if(uni) "U" else "N",
142                x = if(uni) x[FALSE] else x)                x = if(uni) x[FALSE] else x)
143        })        })
# Line 120  Line 162
162                x = if(uni) x[FALSE] else x)                x = if(uni) x[FALSE] else x)
163        })        })
164
165    ## When you assign to a diagonalMatrix, the result should be
166    ## diagonal or sparse
167    setReplaceMethod("[", signature(x = "diagonalMatrix",
168                                    i = "ANY", j = "ANY", value = "ANY"),
169                     function(x, i, j, value) {
170                         r <- callGeneric(x = as(x,"sparseMatrix"),
171                                          i=i, j=j, value=value)
172                         if(isDiagonal(r)) as(r, "diagonalMatrix") else r
173                     })
174
175
176  setMethod("t", signature(x = "diagonalMatrix"),  setMethod("t", signature(x = "diagonalMatrix"),
177            function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })            function(x) { x@Dimnames <- x@Dimnames[2:1] ; x })
178
# Line 130  Line 183
183  setMethod("isSymmetric", signature(object = "diagonalMatrix"),  setMethod("isSymmetric", signature(object = "diagonalMatrix"),
184            function(object) TRUE)            function(object) TRUE)
185
186    setMethod("chol", signature(x = "ddiMatrix"),# pivot = "ANY"
187              function(x, pivot) {
188                  if(any(x@x < 0)) stop("chol() is undefined for diagonal matrix with negative entries")
189                  x@x <- sqrt(x@x)
190                  x
191              })
192    ## chol(L) is L for logical diagonal:
193    setMethod("chol", signature(x = "ldiMatrix"), function(x, pivot) x)
194
195
196  setMethod("diag", signature(x = "diagonalMatrix"),  setMethod("diag", signature(x = "diagonalMatrix"),
197            function(x = 1, nrow, ncol = n) {            function(x = 1, nrow, ncol = n) {
198               if(x@diag == "U")               if(x@diag == "U")
# Line 148  Line 211
211  })  })
212
213  ## Basic Matrix Multiplication {many more to add}  ## Basic Matrix Multiplication {many more to add}
214    ##       ---------------------
215  ## FIXME: extend this for 'ldi', i.e. do "diagonalMatrix"  ## Note that "ldi" logical are treated as numeric
216  diagdiagprod <- function(x, y) {  diagdiagprod <- function(x, y) {
217      if(any(dim(x) != dim(y))) stop("non-matching dimensions")      if(any(dim(x) != dim(y))) stop("non-matching dimensions")
218      if(x@diag != "U") {      if(x@diag != "U") {
219          if(y@diag != "U") x@x <- x@x * y@x          if(y@diag != "U") {
220                nx <- x@x * y@x
221                if(is.numeric(nx) && !is.numeric(x@x))
222                    x <- as(x, "dMatrix")
223                x@x <- as.numeric(nx)
224            }
225          return(x)          return(x)
226      } else ## x is unit diagonal      } else ## x is unit diagonal
227      return(y)      return(y)
228  }  }
229
230  setMethod("%*%", signature(x = "ddiMatrix", y = "ddiMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
231            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
232
233  formals(diagdiagprod) <- alist(x=, y=NULL)  formals(diagdiagprod) <- alist(x=, y=x)
234  setMethod("crossprod", signature(x = "ddiMatrix", y = "ddiMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
235              diagdiagprod, valueClass = "ddiMatrix")
236    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "diagonalMatrix"),
237            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
238  setMethod("tcrossprod", signature(x = "ddiMatrix", y = "ddiMatrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "missing"),
239              diagdiagprod, valueClass = "ddiMatrix")
240    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "missing"),
241            diagdiagprod, valueClass = "ddiMatrix")            diagdiagprod, valueClass = "ddiMatrix")
242
243
# Line 182  Line 254
254  formals(diagmatprod) <- alist(x=, y=NULL)  formals(diagmatprod) <- alist(x=, y=NULL)
255  setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),  setMethod("crossprod", signature(x = "diagonalMatrix", y = "matrix"),
256            diagmatprod)            diagmatprod)
257    setMethod("tcrossprod", signature(x = "diagonalMatrix", y = "matrix"),
258              diagmatprod)
259
260  diagdgeprod <- function(x, y) {  diagdgeprod <- function(x, y) {
261      dx <- dim(x)      dx <- dim(x)
# Line 202  Line 276
276                dx <- dim(x)                dx <- dim(x)
277                dy <- dim(y)                dy <- dim(y)
278                if(dx[2] != dy[1]) stop("non-matching dimensions")                if(dx[2] != dy[1]) stop("non-matching dimensions")
279                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")
280            })            })
281
282  setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),  setMethod("%*%", signature(x = "dgeMatrix", y = "diagonalMatrix"),
# Line 211  Line 285
285                dy <- dim(y)                dy <- dim(y)
286                if(dx[2] != dy[1]) stop("non-matching dimensions")                if(dx[2] != dy[1]) stop("non-matching dimensions")
287                if(y@diag == "N")                if(y@diag == "N")
288                    x@x <- x@x * rep.int(y@x, dx[1])                    x@x <- x@x * rep(y@x, each = dx[1])
289                x                x
290            })            })
291
# Line 233  Line 307
307
308  ## These are cheap implementations via coercion  ## These are cheap implementations via coercion
309
310    setMethod("Ops", signature(e1 = "diagonalMatrix", e2 = "sparseMatrix"),
311              function(e1,e2) callGeneric(as(e1, "sparseMatrix"), e2))
312    setMethod("Ops", signature(e1 = "sparseMatrix", e2 = "diagonalMatrix"),
313              function(e1,e2) callGeneric(e1, as(e2, "sparseMatrix")))
314
315  ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()  ## FIXME?: In theory, this can be done *FASTER*, in some cases, via tapply1()
316
317  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),  setMethod("%*%", signature(x = "diagonalMatrix", y = "sparseMatrix"),
# Line 268  Line 347
347  }  }
348
349  setMethod("show", signature(object = "diagonalMatrix"),  setMethod("show", signature(object = "diagonalMatrix"),
350            function(object) prDiag(object))            function(object) {
351                  d <- dim(object)
352                  cl <- class(object)
353                  cat(sprintf('%d x %d diagonal matrix of class "%s"\n',
354                              d[1], d[2], cl))
355                  prDiag(object)
356              })

Legend:
 Removed from v.1331 changed lines Added in v.1654