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 697, Mon Apr 18 20:18:46 2005 UTC revision 698, Mon Apr 18 20:20:04 2005 UTC
# Line 12  Line 12 
12      d <- dim(object)      d <- dim(object)
13      cl <- class(object)      cl <- class(object)
14      cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))      cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
 ##- no longer needed: have no objects of virtual classes:  
 ##     if(cl == "Matrix") { ## have no data slot  
 ##         cat("Dim = ", d)  
 ##         if(any(sapply(object@Dimnames,length) > 0)) {  
 ##             cat("; Dimnames = ")  
 ##             str(object@Dimnames)  
 ##         }  
 ##         cat("\n")  
 ##     } else { # not "Matrix", hence have data 'x' slot  
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 32  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(object)# as print() S3 methods do      invisible(object)# as print() S3 methods do
27  }  }
28    
29  setMethod("show", signature(object = "ddenseMatrix"), prMatrix)  setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
30    
31  setMethod("show", signature(object = "sparseMatrix"),  ##- ## FIXME: The following is only for the "dMatrix" objects that are not
32     function(object) {  ##- ##        "dense" nor "sparse" -- i.e. "packed" ones :
33         d <- dim(object)  ##- ## But these could be printed better -- "." for structural zeros.
34         cl <- class(object)  ##- setMethod("show", signature(object = "dMatrix"), prMatrix)
35         cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))  ##- ## and improve this as well:
36    ##- setMethod("show", signature(object = "pMatrix"), prMatrix)
37         maxp <- getOption("max.print")  ##- ## this should now be superfluous [keep for safety for the moment]:
        if(prod(d) <= maxp) print(as(object, "matrix"))  
        else { ## d[1] > maxp / d[2] >= nr :  
            cat("\n Not printing large sparse matrix -- maybe increase options(max.print)\n")  
            if(FALSE) { ### need storage economic "[,]" method for sparse!!  
                nr <- maxp %/% d[2]  
                n2 <- ceiling(nr / 2)  
                print(head(m, max(1, n2)))  
                cat("\n ..........\n\n")  
                print(tail(m, max(1, nr - n2)))  
            }  
        }  
         ## DEBUG: cat("str(.):\n") ; str(object)  
        invisible(object)  
    })  
   
 ## this may go away {since sparse matrices need something better!} :  
38  setMethod("show", signature(object = "Matrix"), prMatrix)  setMethod("show", signature(object = "Matrix"), prMatrix)
39    
40  ## should propagate to all subclasses:  ## should propagate to all subclasses:
# Line 105  Line 79 
79    
80  ## Methods for operations where one argument is numeric  ## Methods for operations where one argument is numeric
81    
82    ## Using as.matrix() and rbind()
83    ## in order to get dimnames from names {at least potentially}:
84    
85  setMethod("%*%", signature(x = "Matrix", y = "numeric"),  setMethod("%*%", signature(x = "Matrix", y = "numeric"),
86            function(x, y) callGeneric(x, array(y, c(length(y), 1))))            function(x, y) callGeneric(x, as.matrix(y)))
87    
88  setMethod("%*%", signature(x = "numeric", y = "Matrix"),  setMethod("%*%", signature(x = "numeric", y = "Matrix"),
89            function(x, y) callGeneric(array(x, c(1, length(x))), y))            function(x, y) callGeneric(rbind(x), y))
90    
91  setMethod("crossprod", signature(x = "Matrix", y = "numeric"),  setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
92            function(x, y = NULL) callGeneric(x, array(y, c(length(y), 1))))            function(x, y = NULL) callGeneric(x, as.matrix(y)))
93    
94  setMethod("crossprod", signature(x = "numeric", y = "Matrix"),  setMethod("crossprod", signature(x = "numeric", y = "Matrix"),
95            function(x, y = NULL)  callGeneric(array(x, c(1, length(x))), y))            function(x, y = NULL)  callGeneric(rbind(x), y))
96    
97  setMethod("solve", signature(a = "Matrix", b = "numeric"),  setMethod("solve", signature(a = "Matrix", b = "numeric"),
98            function(a, b, ...) callGeneric(a, array(b, c(length(b), 1))))            function(a, b, ...) callGeneric(a, as.matrix(b)))
   
 if(FALSE) { ##--- not-yet used -- {almost same code also in ./dgeMatrix.R }  
   
 ## utility for as.Matrix() {which is currently invalid }  
 Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,  
                          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  
 }  
   
 as.Matrix <- function(x, tol = .Machine$double.eps)  
 {  
     asObject(if (inherits(x, "Matrix")) x else as.matrix(x),  
              Matrix.class(x, tol = tol))  
 }  
   
 }## not-yet used  

Legend:
Removed from v.697  
changed lines
  Added in v.698

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