SCM

SCM Repository

[matrix] Diff of /pkg/R/Matrix.R
ViewVC logotype

Diff of /pkg/R/Matrix.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 607, Fri Mar 4 17:33:03 2005 UTC revision 871, Fri Aug 26 17:26:49 2005 UTC
# Line 1  Line 1 
1  #### Toplevel ``virtual'' class "Matrix"  #### Toplevel ``virtual'' class "Matrix"
2    
3  ## probably not needed eventually:  ## probably not needed eventually:
4  setAs(from = "Matrix", to = "matrix",  setAs(from = "ddenseMatrix", to = "matrix",
5        function(from) {        function(from) {
6            if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")            if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
7            array(as.numeric(NA), dim = d, dimnames = dimnames(from))            array(from@x, dim = d, dimnames = dimnames(from))
8        })        })
9    
 prMatrix <-  
10      ## private function to be used as show() method possibly more than once      ## private function to be used as show() method possibly more than once
11      function(object) {  prMatrix <- function(object) {
12          d <- dim(object)          d <- dim(object)
13          cat(paste(d, collapse= " x "), " Matrix of class ",      cl <- class(object)
14              sQuote(class(object)),"\n", sep='')      cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
15          m <- as(object, "matrix")          m <- as(object, "matrix")
16          maxp <- getOption("max.print")          maxp <- getOption("max.print")
17          if(prod(d) <= maxp) print(m)          if(prod(d) <= maxp) print(m)
# Line 24  Line 23 
23              print(tail(m, max(1, nr - n2)))              print(tail(m, max(1, nr - n2)))
24          }          }
25          ## DEBUG: cat("str(.):\n") ; str(object)          ## DEBUG: cat("str(.):\n") ; str(object)
26          invisible()      invisible(object)# as print() S3 methods do
27      }      }
28    
29  setMethod("show", signature(object = "ddenseMatrix"), prMatrix)  setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
30  ## this may go away {since sparse matrices need something better!} :  
31    ##- ## FIXME: The following is only for the "dMatrix" objects that are not
32    ##- ##        "dense" nor "sparse" -- i.e. "packed" ones :
33    ##- ## But these could be printed better -- "." for structural zeros.
34    ##- setMethod("show", signature(object = "dMatrix"), prMatrix)
35    ##- ## and improve this as well:
36    ##- setMethod("show", signature(object = "pMatrix"), prMatrix)
37    ##- ## this should now be superfluous [keep for safety for the moment]:
38  setMethod("show", signature(object = "Matrix"), prMatrix)  setMethod("show", signature(object = "Matrix"), prMatrix)
39    
40    ## should propagate to all subclasses:
41    setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
42    
43  setMethod("dim", signature(x = "Matrix"),  setMethod("dim", signature(x = "Matrix"),
44            function(x) x@Dim, valueClass = "integer")            function(x) x@Dim, valueClass = "integer")
45  setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)  setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
# Line 49  Line 58 
58  setMethod("dimnames<-", signature(x = "Matrix", value = "list"),  setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
59            dimnamesGets)            dimnamesGets)
60    
61    setMethod("unname", signature("Matrix", force="missing"),
62              function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
63    
64  Matrix <-  Matrix <-
65      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)      function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
# Line 66  Line 77 
77      as(val, "dgeMatrix")      as(val, "dgeMatrix")
78  }  }
79    
80    ## Methods for operations where one argument is numeric
81    
82  if(FALSE) { ##--- not-yet used -- {almost same code also in ./dgeMatrix.R }  ## Using as.matrix() and rbind()
83    ## in order to get dimnames from names {at least potentially}:
84    
85  ## utility for as.Matrix() {which is currently invalid }  setMethod("%*%", signature(x = "Matrix", y = "numeric"),
86  Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,            function(x, y) callGeneric(x, as.matrix(y)))
                          triangularity = c(TRUE, TRUE),  
                          orthogonality = c(TRUE, TRUE),  
                          normality = c(TRUE, TRUE))  
 {  
     val <- "Matrix"  
     x <- as.matrix(x)  
     if (symmetry) {  
         if (is.Hermitian(x, tol)) val <- c("Hermitian", val)  
     }  
     if (triangularity[1]) {  
         if (is.LowerTriangular(x, tol)) {  
             val <- c("LowerTriangular", val)  
             if (unit.diagonal)  
                 if (max(Mod(diag(x) - 1)) <= tol)  
                     val <- c("UnitLowerTriangular", val)  
         }  
     }  
     if (triangularity[2]) {  
         if (is.UpperTriangular(x, tol)) {  
             val <- c("UpperTriangular", val)  
             if (unit.diagonal)  
                 if (max(Mod(diag(x) - 1)) <= tol)  
                     val <- c("UnitUpperTriangular", val)  
         }  
     }  
     if (orthogonality[1]) {  
         if (is.ColOrthonormal(x, tol)) {  
             val <- c("ColOrthoNormal", "ColOrthogonal", val)  
         } else {  
             if (Orthogonal.test(x, normal = FALSE) <= tol)  
                 val <- c("ColOrthogonal", val)  
         }  
     }  
     if (orthogonality[2]) {  
         if (normality[2] && is.RowOrthonormal(x, tol)) {  
             val <- c("RowOrthoNormal", "RowOrthogonal", val)  
         } else {  
             if (Orthogonal.test(x, byrow = TRUE, normal = FALSE) <= tol)  
                 val <- c("RowOrthogonal", val)  
         }  
     }  
     val  
 }  
87    
88  as.Matrix <- function(x, tol = .Machine$double.eps)  setMethod("%*%", signature(x = "numeric", y = "Matrix"),
89  {            function(x, y) callGeneric(rbind(x), y))
90      asObject(if (inherits(x, "Matrix")) x else as.matrix(x),  
91               Matrix.class(x, tol = tol))  setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
92  }            function(x, y = NULL) callGeneric(x, as.matrix(y)))
93    
94  }## not-yet used  setMethod("crossprod", signature(x = "numeric", y = "Matrix"),
95              function(x, y = NULL)  callGeneric(rbind(x), y))
96    
97    setMethod("solve", signature(a = "Matrix", b = "numeric"),
98              function(a, b, ...) callGeneric(a, as.matrix(b)))
99    
100    ### --------------------------------------------------------------------------
101    ###
102    ### Subsetting "["  and
103    ### SubAssign  "[<-" : The "missing" cases can be dealt with here, "at the top":
104    
105    ## "x[]":
106    setMethod("[", signature(x = "Matrix",
107                             i = "missing", j = "missing", drop = "ANY"),
108              function (x, i, j, drop) x)
109    ## missing 'drop' --> 'drop = TRUE'
110    ##                     -----------
111    ## select rows
112    setMethod("[", signature(x = "Matrix", i = "numeric", j = "missing",
113                             drop = "missing"),
114              function(x,i,j, drop) callGeneric(x, i=i, drop= TRUE))
115    ## select columns
116    setMethod("[", signature(x = "Matrix", i = "missing", j = "numeric",
117                             drop = "missing"),
118              function(x,i,j, drop) callGeneric(x, j=j, drop= TRUE))
119    setMethod("[", signature(x = "Matrix", i = "numeric", j = "numeric",
120                             drop = "missing"),
121              function(x,i,j, drop) callGeneric(x, i=i, j=j, drop= TRUE))
122    
123    ## "FIXME:"
124    ## How can we get at   A[ ij ]  where ij is (i,j) 2-column matrix?
125    ##  and                A[ LL ]  where LL is a logical *vector*
126    
127    
128    
129    ### "[<-" : -----------------
130    
131    ## x[] <- value :
132    setReplaceMethod("[", signature(x = "Matrix", i = "missing", j = "missing",
133                                    value = "vector"),##  double/logical/...
134              function (x, value) { x@x <- value ; validObject(x); x })
135    
136    ## Otherwise (value is not "vector"): bail out
137    setReplaceMethod("[", signature(x = "Matrix", i = "ANY", j = "ANY",
138                                    value = "ANY"),
139              function (x, i, j, value) stop("RHS 'value' must be of class \"vector\""))
140    
141    
142    
143    if(FALSE) ## The following can't work as long as cbind is function(..., *)
144    setMethod("cbind", signature(a = "Matrix", b = "Matrix"),
145              function(a, b, ...) {
146                  da <- Dim(a)
147                  db <- Dim(b)
148                  if(da[1] != db[1])
149                      stop("Matrices must have same number of rows for cbind()ing")
150              })

Legend:
Removed from v.607  
changed lines
  Added in v.871

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