The R Project SVN R-packages

Rev

Rev 1321 | Rev 1746 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 1321 Rev 1387
Line 1... Line 1...
1 
#### Toplevel ``virtual'' class "Matrix"
 1 
#### Toplevel ``virtual'' class "Matrix"
2 
 
 2 
 
3 
## probably not needed eventually:
 3 
## probably not needed eventually:
4 
setAs(from = "ddenseMatrix", to = "matrix",
 4 
setAs(from = "ddenseMatrix", to = "matrix",
5 
      function(from) {
 5 
      function(from) {
6 
          if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
 6 
	  if(length(d <- dim(from)) != 2) stop("dim(.) has not length 2")
7 
          array(from@x, dim = d, dimnames = dimnames(from))
 7 
	  array(from@x, dim = d, dimnames = dimnames(from))
8 
      })
 8 
      })
9 
 
 9 
 
10 
## private function to be used as show() method possibly more than once
 10 
## private function to be used as show() method possibly more than once
11 
prMatrix <- function(object) {
 11 
prMatrix <- function(object) {
12 
    d <- dim(object)
 12 
    d <- dim(object)
13 
    cl <- class(object)
 13 
    cl <- class(object)
14 
    cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
 14 
    cat(sprintf('%d x %d Matrix of class "%s"\n', d[1], d[2], cl))
15 
##- no longer needed: have no objects of virtual classes:
 - 
 
16 
##     if(cl == "Matrix") { ## have no data slot
 - 
 
17 
##         cat("Dim = ", d)
 - 
 
18 
##         if(any(sapply(object@Dimnames,length) > 0)) {
 - 
 
19 
##             cat("; Dimnames = ")
 - 
 
20 
##             str(object@Dimnames)
 - 
 
21 
##         }
 - 
 
22 
##         cat("\n")
 - 
 
23 
##     } else { # not "Matrix", hence have data 'x' slot
 - 
 
24 
        m <- as(object, "matrix")
 15 
    m <- as(object, "matrix")
25 
        maxp <- getOption("max.print")
 16 
    maxp <- getOption("max.print")
26 
        if(prod(d) <= maxp) print(m)
 17 
    if(prod(d) <= maxp) print(m)
27 
        else { ## d[1] > maxp / d[2] >= nr :
 18 
    else { ## d[1] > maxp / d[2] >= nr :
28 
            nr <- maxp %/% d[2]
 19 
	nr <- maxp %/% d[2]
29 
            n2 <- ceiling(nr / 2)
 20 
	n2 <- ceiling(nr / 2)
30 
            print(head(m, max(1, n2)))
 21 
	print(head(m, max(1, n2)))
31 
            cat("\n ..........\n\n")
 22 
	cat("\n ..........\n\n")
32 
            print(tail(m, max(1, nr - n2)))
 23 
	print(tail(m, max(1, nr - n2)))
33 
        }
 24 
    }
34 
        ## DEBUG: cat("str(.):\n") ; str(object)
 25 
    ## DEBUG: cat("str(.):\n") ; str(object)
35 
##    }
 - 
 
36 
    invisible(object)# as print() S3 methods do
 26 
    invisible(object)# as print() S3 methods do
37 
}
 27 
}
38 
 
 28 
 
39 
setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
 29 
setMethod("show", signature(object = "ddenseMatrix"), prMatrix)
40 
 
 30 
 
41 
setMethod("show", signature(object = "sparseMatrix"),
 - 
 
42 
   function(object) {
 - 
 
43 
       d <- dim(object)
 - 
 
44 
       cl <- class(object)
 - 
 
45 
       cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))
 - 
 
46 
 
 - 
 
47 
       maxp <- getOption("max.print")
 - 
 
48 
       if(prod(d) <= maxp) print(as(object, "matrix"))
 31 
##- ## FIXME: The following is only for the "dMatrix" objects that are not
49 
       else { ## d[1] > maxp / d[2] >= nr :
 32 
##- ##	      "dense" nor "sparse" -- i.e. "packed" ones :
50 
           cat("\n Not printing large sparse matrix -- maybe increase options(max.print)\n")
 33 
##- ## But these could be printed better -- "." for structural zeros.
51 
           if(FALSE) { ### need storage economic "[,]" method for sparse!!
 34 
##- setMethod("show", signature(object = "dMatrix"), prMatrix)
52 
               nr <- maxp %/% d[2]
 35 
##- ## and improve this as well:
53 
               n2 <- ceiling(nr / 2)
 - 
 
54 
               print(head(m, max(1, n2)))
 - 
 
55 
               cat("\n ..........\n\n")
 - 
 
56 
               print(tail(m, max(1, nr - n2)))
 36 
##- setMethod("show", signature(object = "pMatrix"), prMatrix)
57 
           }
 - 
 
58 
       }
 - 
 
59 
        ## DEBUG: cat("str(.):\n") ; str(object)
 - 
 
60 
       invisible(object)
 - 
 
61 
   })
 - 
 
62 
 
 - 
 
63 
## this may go away {since sparse matrices need something better!} :
 37 
##- ## this should now be superfluous [keep for safety for the moment]:
64 
setMethod("show", signature(object = "Matrix"), prMatrix)
 38 
setMethod("show", signature(object = "Matrix"), prMatrix)
65 
 
 39 
 
66 
## should propagate to all subclasses:
 40 
## should propagate to all subclasses:
67 
setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
 41 
setMethod("as.matrix", signature(x = "Matrix"), function(x) as(x, "matrix"))
68 
 
 42 
 
69 
setMethod("dim", signature(x = "Matrix"),
 43 
setMethod("dim", signature(x = "Matrix"),
70 
          function(x) x@Dim, valueClass = "integer")
 44 
	  function(x) x@Dim, valueClass = "integer")
71 
setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
 45 
setMethod("dimnames", signature(x = "Matrix"), function(x) x@Dimnames)
72 
## not exported but used more than once for "dimnames<-" method :
 46 
## not exported but used more than once for "dimnames<-" method :
73 
## -- or do only once for all "Matrix" classes ??
 47 
## -- or do only once for all "Matrix" classes ??
74 
dimnamesGets <- function (x, value) {
 48 
dimnamesGets <- function (x, value) {
75 
    d <- dim(x)
 49 
    d <- dim(x)
76 
    if (!is.list(value) || length(value) != 2 ||
 50 
    if (!is.list(value) || length(value) != 2 ||
77 
        !(is.null(v1 <- value[[1]]) || length(v1) == d[1]) ||
 51 
	!(is.null(v1 <- value[[1]]) || length(v1) == d[1]) ||
78 
        !(is.null(v2 <- value[[2]]) || length(v2) == d[2]))
 52 
	!(is.null(v2 <- value[[2]]) || length(v2) == d[2]))
79 
        stop(sprintf("invalid dimnames given for '%s' object", class(x)))
 53 
	stop(sprintf("invalid dimnames given for '%s' object", class(x)))
80 
    x@Dimnames <- list(if(!is.null(v1)) as.character(v1),
 54 
    x@Dimnames <- list(if(!is.null(v1)) as.character(v1),
81 
                       if(!is.null(v2)) as.character(v2))
 55 
		       if(!is.null(v2)) as.character(v2))
82 
    x
 56 
    x
83 
}
 57 
}
84 
setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
 58 
setMethod("dimnames<-", signature(x = "Matrix", value = "list"),
85 
          dimnamesGets)
 59 
	  dimnamesGets)
86 
 
 60 
 
87 
setMethod("unname", signature("Matrix", force="missing"),
 61 
setMethod("unname", signature("Matrix", force="missing"),
88 
          function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
 62 
	  function(obj) { obj@Dimnames <- list(NULL,NULL); obj})
89 
 
 63 
 
90 
Matrix <-
 64 
Matrix <-
91 
    function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
 65 
    function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
92 
{
 66 
{
93 
    if (is(data, "Matrix")) return(data)
 67 
    if (is(data, "Matrix")) return(data)
94 
    if (is.matrix(data)) { val <- data }
 68 
    if (is.matrix(data)) { val <- data }
95 
    else { ## cut & paste from "base::matrix" :
 69 
    else { ## cut & paste from "base::matrix" :
96 
        if (missing(nrow))
 70 
	if (missing(nrow))
97 
            nrow <- ceiling(length(data)/ncol)
 71 
	    nrow <- ceiling(length(data)/ncol)
98 
        else if (missing(ncol))
 72 
	else if (missing(ncol))
99 
            ncol <- ceiling(length(data)/nrow)
 73 
	    ncol <- ceiling(length(data)/nrow)
100 
        val <- .Internal(matrix(data, nrow, ncol, byrow))
 74 
	val <- .Internal(matrix(data, nrow, ncol, byrow))
101 
        dimnames(val) <- dimnames
 75 
	dimnames(val) <- dimnames
102 
    }
 76 
    }
103 
    as(val, "dgeMatrix")
 77 
    as(val, "dgeMatrix")
104 
}
 78 
}
105 
 
 79 
 
106 
## Methods for operations where one argument is numeric
 80 
## Methods for operations where one argument is numeric
107 
 
 81 
 
- 
 
 82 
## Using as.matrix() and rbind()
- 
 
 83 
## in order to get dimnames from names {at least potentially}:
- 
 
 84 
 
108 
setMethod("%*%", signature(x = "Matrix", y = "numeric"),
 85 
setMethod("%*%", signature(x = "Matrix", y = "numeric"),
109 
          function(x, y) callGeneric(x, array(y, c(length(y), 1))))
 86 
	  function(x, y) callGeneric(x, as.matrix(y)))
110 
 
 87 
 
111 
setMethod("%*%", signature(x = "numeric", y = "Matrix"),
 88 
setMethod("%*%", signature(x = "numeric", y = "Matrix"),
112 
          function(x, y) callGeneric(array(x, c(1, length(x))), y))
 89 
	  function(x, y) callGeneric(rbind(x), y))
113 
 
 90 
 
114 
setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
 91 
setMethod("crossprod", signature(x = "Matrix", y = "numeric"),
115 
          function(x, y = NULL) callGeneric(x, array(y, c(length(y), 1))))
 92 
	  function(x, y = NULL) callGeneric(x, as.matrix(y)))
116 
 
 93 
 
117 
setMethod("crossprod", signature(x = "numeric", y = "Matrix"),
 94 
setMethod("crossprod", signature(x = "numeric", y = "Matrix"),
118 
          function(x, y = NULL)  callGeneric(array(x, c(1, length(x))), y))
 95 
	  function(x, y = NULL)	 callGeneric(rbind(x), y))
119 
 
 96 
 
120 
setMethod("solve", signature(a = "Matrix", b = "numeric"),
 97 
setMethod("solve", signature(a = "Matrix", b = "numeric"),
121 
          function(a, b, ...) callGeneric(a, array(b, c(length(b), 1))))
 98 
	  function(a, b, ...) callGeneric(a, as.matrix(b)))
122 
 
 - 
 
123 
if(FALSE) { ##--- not-yet used -- {almost same code also in ./dgeMatrix.R }
 - 
 
124 
 
 - 
 
125 
## utility for as.Matrix() {which is currently invalid }
 - 
 
126 
Matrix.class <- function(x, tol = 0, symmetry = TRUE, unit.diagonal = TRUE,
 - 
 
127 
                         triangularity = c(TRUE, TRUE),
 - 
 
128 
                         orthogonality = c(TRUE, TRUE),
 - 
 
129 
                         normality = c(TRUE, TRUE))
 - 
 
130 
{
 - 
 
131 
    val <- "Matrix"
 - 
 
132 
    x <- as.matrix(x)
 - 
 
133 
    if (symmetry) {
 - 
 
134 
        if (is.Hermitian(x, tol)) val <- c("Hermitian", val)
 - 
 
135 
    }
 - 
 
136 
    if (triangularity[1]) {
 - 
 
137 
        if (is.LowerTriangular(x, tol)) {
 - 
 
138 
            val <- c("LowerTriangular", val)
 - 
 
139 
            if (unit.diagonal)
 - 
 
140 
                if (max(Mod(diag(x) - 1)) <= tol)
 - 
 
141 
                    val <- c("UnitLowerTriangular", val)
 - 
 
142 
        }
 - 
 
143 
    }
 - 
 
144 
    if (triangularity[2]) {
 - 
 
145 
        if (is.UpperTriangular(x, tol)) {
 - 
 
146 
            val <- c("UpperTriangular", val)
 - 
 
147 
            if (unit.diagonal)
 - 
 
148 
                if (max(Mod(diag(x) - 1)) <= tol)
 - 
 
149 
                    val <- c("UnitUpperTriangular", val)
 - 
 
150 
        }
 - 
 
151 
    }
 - 
 
152 
    if (orthogonality[1]) {
 - 
 
153 
        if (is.ColOrthonormal(x, tol)) {
 - 
 
154 
            val <- c("ColOrthoNormal", "ColOrthogonal", val)
 - 
 
155 
        } else {
 - 
 
156 
            if (Orthogonal.test(x, normal = FALSE) <= tol)
 - 
 
157 
                val <- c("ColOrthogonal", val)
 - 
 
158 
        }
 - 
 
159 
    }
 - 
 
160 
    if (orthogonality[2]) {
 - 
 
161 
        if (normality[2] && is.RowOrthonormal(x, tol)) {
 - 
 
162 
            val <- c("RowOrthoNormal", "RowOrthogonal", val)
 - 
 
163 
        } else {
 - 
 
164 
            if (Orthogonal.test(x, byrow = TRUE, normal = FALSE) <= tol)
 - 
 
165 
                val <- c("RowOrthogonal", val)
 - 
 
166 
        }
 - 
 
167 
    }
 - 
 
168 
    val
 - 
 
169 
}
 - 
 
170 
 
 - 
 
171 
as.Matrix <- function(x, tol = .Machine$double.eps)
 - 
 
172 
{
 - 
 
173 
    asObject(if (inherits(x, "Matrix")) x else as.matrix(x),
 - 
 
174 
	     Matrix.class(x, tol = tol))
 - 
 
175 
}
 - 
 
176 
 
 - 
 
177 
}## not-yet used
 -