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 2202, Mon Jun 9 21:36:21 2008 UTC revision 2203, Sat Jun 14 20:09:17 2008 UTC
# Line 230  Line 230 
230  ## FIXME(?) -- ``merge this'' (at least ``synchronize'') with  ## FIXME(?) -- ``merge this'' (at least ``synchronize'') with
231  ## - - -   prMatrix() from ./Auxiliaries.R  ## - - -   prMatrix() from ./Auxiliaries.R
232  ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"  ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"
233  ## --> help for this is currently (rudimentary) in ../man/sparseMatrix-class.Rd  ##
234  printSpMatrix <- function(x, digits = getOption("digits"),  printSpMatrix <- function(x, digits = getOption("digits"),
235                         maxp = getOption("max.print"), zero.print = ".",                         maxp = getOption("max.print"), zero.print = ".",
236                         col.names, note.dropping.colnames = TRUE,                         col.names, note.dropping.colnames = TRUE,
# Line 251  Line 251 
251      logi <- extends(cl,"lsparseMatrix") || extends(cl,"nsparseMatrix")      logi <- extends(cl,"lsparseMatrix") || extends(cl,"nsparseMatrix")
252      if(logi)      if(logi)
253          cx <- array("N", dim(m), dimnames=dn)          cx <- array("N", dim(m), dimnames=dn)
254      else { ## numeric (or --not yet-- complex):      else { ## numeric (or --not yet implemented-- complex):
255          cx <- apply(m, 2, format)          cx <- apply(m, 2, format)
256          if(is.null(dim(cx))) {# e.g. in 1 x 1 case          if(is.null(dim(cx))) {# e.g. in 1 x 1 case
257              dim(cx) <- dim(m)              dim(cx) <- dim(m)
# Line 294  Line 294 
294          ## show only "structural" zeros as 'zero.print', not all of them..          ## show only "structural" zeros as 'zero.print', not all of them..
295          ## -> cannot use 'm'          ## -> cannot use 'm'
296          d <- dim(cx)          d <- dim(cx)
297          ne <- length(iN0 <- 1L + encodeInd(non0ind(x, cl), nr = d[1]))          ne <- length(iN0 <- 1L + .Call(m_encodeInd, non0ind(x, cl), di = d))
298          if(0 < ne && ne < prod(d)) {          if(0 < ne && ne < prod(d)) {
299              align <- match.arg(align)              align <- match.arg(align)
300              if(align == "fancy" && !is.integer(m)) {              if(align == "fancy" && !is.integer(m)) {
# Line 330  Line 330 
330      ## right = TRUE : cheap attempt to get better "." alignment      ## right = TRUE : cheap attempt to get better "." alignment
331      print(cx, quote = FALSE, right = TRUE, max = maxp)      print(cx, quote = FALSE, right = TRUE, max = maxp)
332      invisible(x)      invisible(x)
333  }  } ## printSpMatrix()
   
 setMethod("print", signature(x = "sparseMatrix"), printSpMatrix)  
   
 setMethod("show", signature(object = "sparseMatrix"),  
    function(object) {  
        d <- dim(object)  
        cl <- class(object)  
        cat(sprintf('%d x %d sparse Matrix of class "%s"\n', d[1], d[2], cl))  
        maxp <- getOption("max.print")  
        if(prod(d) <= maxp)  
            printSpMatrix(object, maxp = maxp)  
        else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:  
334    
335             nR <- d[1] # nrow  printSpMatrix2 <- function(x, digits = getOption("digits"),
336                               maxp = getOption("max.print"), zero.print = ".",
337                               col.names, note.dropping.colnames = TRUE,
338                               suppRows = NULL, suppCols = NULL,
339                               col.trailer = if(suppCols) "......" else "",
340                               align = c("fancy", "right"))
341    {
342        d <- dim(x)
343        if((identical(suppRows,FALSE) && identical(suppCols, FALSE)) ||
344           (!isTRUE(suppRows) && !isTRUE(suppCols) && prod(d) <= maxp))
345        {
346            if(missing(col.trailer) && is.null(suppCols))
347                suppCols <- FALSE # for 'col.trailer'
348            printSpMatrix(x, digits=digits, maxp=maxp,
349                          zero.print=zero.print, col.names=col.names,
350                          note.dropping.colnames=note.dropping.colnames,
351                          col.trailer=col.trailer, align=align)
352        } else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:
353            nR <- d[1] ## nrow
354             useW <- getOption("width") - (format.info(nR)[1] + 3+1)             useW <- getOption("width") - (format.info(nR)[1] + 3+1)
355             ##                           space for "[<last>,] "             ##                           space for "[<last>,] "
356    
357             ## --> suppress rows and/or columns in printing ...             ## --> suppress rows and/or columns in printing ...
358    
359             suppCols <- (d[2] * 2 > useW)          if(is.null(suppCols)) suppCols <- (d[2] * 2 > useW)
360             nc <- if(suppCols) (useW - (1 + 6)) %/% 2 else d[2]          nc <- if(suppCols) (useW - (1 + nchar(col.trailer))) %/% 2 else d[2]
            ##                          sp+ col.trailer  
            col.trailer <- if(suppCols) "......" else ""  
361             nr <- maxp %/% nc             nr <- maxp %/% nc
362             suppRows <- (nr < nR)          if(is.null(suppRows)) suppRows <- (nr < nR)
363    
364            sTxt <- c("in show(); maybe adjust 'options(max.print= *)'",
365                      "\n ..............................\n")
366             if(suppRows) {             if(suppRows) {
367                 if(suppCols)                 if(suppCols)
368                     object <- object[ , 1:nc, drop = FALSE]                  x <- x[ , 1:nc, drop = FALSE]
369                 n2 <- ceiling(nr / 2)                 n2 <- ceiling(nr / 2)
370                 printSpMatrix(object[seq_len(min(nR, max(1, n2))), , drop=FALSE],              printSpMatrix(x[seq_len(min(nR, max(1, n2))), , drop=FALSE],
371                               col.trailer = col.trailer)                            digits=digits, maxp=maxp,
372                              zero.print=zero.print, col.names=col.names,
373                              note.dropping.colnames=note.dropping.colnames,
374                              col.trailer = col.trailer, align=align)
375                 cat("\n ..............................",                 cat("\n ..............................",
376                     "\n ..........suppressing rows in show(); maybe adjust 'options(max.print= *)'",                  "\n ........suppressing rows ", sTxt, "\n", sep='')
                    "\n ..............................\n\n", sep='')  
377                 ## tail() automagically uses "[..,]" rownames:                 ## tail() automagically uses "[..,]" rownames:
378                 printSpMatrix(tail(object, max(1, nr-n2)),              printSpMatrix(tail(x, max(1, nr-n2)),
379                               col.trailer = col.trailer)                            digits=digits, maxp=maxp,
380                              zero.print=zero.print, col.names=col.names,
381                              note.dropping.colnames=note.dropping.colnames,
382                              col.trailer = col.trailer, align=align)
383             }             }
384             else if(suppCols) {             else if(suppCols) {
385                 printSpMatrix(object[ , 1:nc , drop = FALSE],              printSpMatrix(x[ , 1:nc , drop = FALSE],
386                               col.trailer = col.trailer)                            digits=digits, maxp=maxp,
387                              zero.print=zero.print, col.names=col.names,
388                 cat("\n .....suppressing columns in show(); maybe adjust 'options(max.print= *)'",                            note.dropping.colnames=note.dropping.colnames,
389                     "\n ..............................\n", sep='')                            col.trailer = col.trailer, align=align)
390                cat("\n .....suppressing columns ", sTxt, sep='')
391             }             }
392             else stop("logic programming error in printSpMatrix(), please report")          else stop("logic programming error in printSpMatrix2(), please report")
393    
394             invisible(object)          invisible(x)
395         }         }
396    } ## printSpMatrix2 ()
397    
398    setMethod("print", signature(x = "sparseMatrix"), printSpMatrix)
399    
400    setMethod("show", signature(object = "sparseMatrix"),
401              function(object) {
402                  d <- dim(object)
403                  cl <- class(object)
404                  cat(sprintf('%d x %d sparse Matrix of class "%s"\n',
405                              d[1], d[2], cl))
406                  printSpMatrix2(object)
407     })     })
408    
409    

Legend:
Removed from v.2202  
changed lines
  Added in v.2203

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