SCM

SCM Repository

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

Diff of /pkg/R/sparseMatrix.R

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

revision 1902, Sat Jun 16 15:54:54 2007 UTC revision 1903, Sat Jun 16 18:31:51 2007 UTC
# Line 222  Line 222 
222    
223  ## FIXME(?) -- ``merge this'' (at least ``synchronize'') with  ## FIXME(?) -- ``merge this'' (at least ``synchronize'') with
224  ## - - -   prMatrix() from ./Auxiliaries.R  ## - - -   prMatrix() from ./Auxiliaries.R
225  prSpMatrix <- function(object, digits = getOption("digits"),  prSpMatrix <- function(x, digits = getOption("digits"),
226                         maxp = getOption("max.print"), zero.print = ".",                         maxp = getOption("max.print"), zero.print = ".",
227                           col.names = FALSE, note.dropping.colnames = TRUE,
228                         col.trailer = '', align = c("fancy", "right"))                         col.trailer = '', align = c("fancy", "right"))
229  ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"  ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"
230  {  {
231      cl <- getClassDef(class(object))      cl <- getClassDef(class(x))
232      stopifnot(extends(cl, "sparseMatrix"))      stopifnot(extends(cl, "sparseMatrix"))
233      d <- dim(object)      d <- dim(x)
234      if(prod(d) > maxp) { # "Large" => will be "cut"      if(prod(d) > maxp) { # "Large" => will be "cut"
235          ## only coerce to dense that part which won't be cut :          ## only coerce to dense that part which won't be cut :
236          nr <- maxp %/% d[2]          nr <- maxp %/% d[2]
237          m <- as(object[1:max(1, nr), ,drop=FALSE], "Matrix")          m <- as(x[1:max(1, nr), ,drop=FALSE], "Matrix")
238      } else {      } else {
239          m <- as(object, "matrix")          m <- as(x, "matrix")
240      }      }
241      logi <- extends(cl,"lsparseMatrix") || extends(cl,"nsparseMatrix")      logi <- extends(cl,"lsparseMatrix") || extends(cl,"nsparseMatrix")
242      if(logi)      if(logi)
243          x <- array("N", # or as.character(NA),          cx <- array("N", # or as.character(NA),
244                     dim(m), dimnames=dimnames(m))                     dim(m), dimnames=dimnames(m))
245      else { ## numeric (or --not yet-- complex):      else { ## numeric (or --not yet-- complex):
246          x <- apply(m, 2, format)          cx <- apply(m, 2, format)
247          if(is.null(dim(x))) {# e.g. in  1 x 1 case          if(is.null(dim(cx))) {# e.g. in 1 x 1 case
248              dim(x) <- dim(m)              dim(cx) <- dim(m)
249              dimnames(x) <- dimnames(m)              dimnames(cx) <- dimnames(m)
250          }          }
251      }      }
252      x <- emptyColnames(x, msg.if.not.empty = TRUE)      if(!col.names)
253            cx <- emptyColnames(cx, msg.if.not.empty = note.dropping.colnames)
254      if(is.logical(zero.print))      if(is.logical(zero.print))
255          zero.print <- if(zero.print) "0" else " "          zero.print <- if(zero.print) "0" else " "
256      if(logi) {      if(logi) {
257          x[!m] <- zero.print          cx[!m] <- zero.print
258          x[m] <- "|"          cx[m] <- "|"
259      } else { # non logical      } else { # non logical
260          ## show only "structural" zeros as 'zero.print', not all of them..          ## show only "structural" zeros as 'zero.print', not all of them..
261          ## -> cannot use 'm'          ## -> cannot use 'm'
262          d <- dim(x)          d <- dim(cx)
263          ne <- length(iN0 <- 1L + encodeInd(non0ind(object, cl), nr = d[1]))          ne <- length(iN0 <- 1L + encodeInd(non0ind(x, cl), nr = d[1]))
264          if(0 < ne && ne < prod(d)) {          if(0 < ne && ne < prod(d)) {
265              align <- match.arg(align)              align <- match.arg(align)
266              if(align == "fancy") {              if(align == "fancy") {
# Line 285  Line 287 
287                      zero.print <- rep.int(zero.print, length(cols))                      zero.print <- rep.int(zero.print, length(cols))
288              } ## else "right" : nothing to do              } ## else "right" : nothing to do
289    
290              x[-iN0] <- zero.print              cx[-iN0] <- zero.print
291          } else if (ne == 0)# all zeroes          } else if (ne == 0)# all zeroes
292              x[] <- zero.print              cx[] <- zero.print
293      }      }
294      if(col.trailer != '')      if(col.trailer != '')
295          x <- cbind(x, col.trailer, deparse.level = 0)          cx <- cbind(cx, col.trailer, deparse.level = 0)
296      ## right = TRUE : cheap attempt to get better "." alignment      ## right = TRUE : cheap attempt to get better "." alignment
297      print(x, quote = FALSE, right = TRUE, max = maxp)      print(cx, quote = FALSE, right = TRUE, max = maxp)
298      invisible(object)      invisible(x)
299  }  }
300    
301    setMethod("print", signature(x = "sparseMatrix"), prSpMatrix)
302    
303  setMethod("show", signature(object = "sparseMatrix"),  setMethod("show", signature(object = "sparseMatrix"),
304     function(object) {     function(object) {
305         d <- dim(object)         d <- dim(object)

Legend:
Removed from v.1902  
changed lines
  Added in v.1903

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