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 1736, Tue Jan 23 17:09:41 2007 UTC revision 1737, Tue Jan 23 17:14:20 2007 UTC
# Line 189  Line 189 
189    
190  ## Group Methods  ## Group Methods
191    
192  ##-> see ./Ops.R  setMethod("Math",
193              signature(x = "sparseMatrix"),
194              function(x) callGeneric(as(x, "CsparseMatrix")))
195    
196    ## further group methods -> see ./Ops.R
197    
198    
199    
# Line 199  Line 203 
203  ## - - -   prMatrix() from ./Auxiliaries.R  ## - - -   prMatrix() from ./Auxiliaries.R
204  prSpMatrix <- function(object, digits = getOption("digits"),  prSpMatrix <- function(object, digits = getOption("digits"),
205                         maxp = getOption("max.print"), zero.print = ".",                         maxp = getOption("max.print"), zero.print = ".",
206                           row.trailer = '',
207                         align = c("fancy", "right"))                         align = c("fancy", "right"))
208  ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"  ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"
209  {  {
210      stopifnot(is(object, "sparseMatrix"))      cl <- getClassDef(class(object))
211        stopifnot(extends(cl, "sparseMatrix"))
212      d <- dim(object)      d <- dim(object)
213      if(prod(d) > maxp) { # "Large" => will be "cut"      if(prod(d) > maxp) { # "Large" => will be "cut"
214          ## only coerce to dense that part which won't be cut :          ## only coerce to dense that part which won't be cut :
# Line 211  Line 217 
217      } else {      } else {
218          m <- as(object, "matrix")          m <- as(object, "matrix")
219      }      }
220      logi <- is(object,"lsparseMatrix") || is(object,"nsparseMatrix")      logi <- extends(cl,"lsparseMatrix") || extends(cl,"nsparseMatrix")
221      if(logi)      if(logi)
222          x <- array("N", # or as.character(NA),          x <- array("N", # or as.character(NA),
223                     dim(m), dimnames=dimnames(m))                     dim(m), dimnames=dimnames(m))
# Line 232  Line 238 
238          ## show only "structural" zeros as 'zero.print', not all of them..          ## show only "structural" zeros as 'zero.print', not all of them..
239          ## -> cannot use 'm'          ## -> cannot use 'm'
240          d <- dim(x)          d <- dim(x)
241          ne <- length(iN0 <- 1:1 + encodeInd(non0ind(object), nr = d[1]))          ne <- length(iN0 <- 1:1 + encodeInd(non0ind(object, cl), nr = d[1]))
242          if(0 < ne && ne < prod(d)) {          if(0 < ne && ne < prod(d)) {
243              align <- match.arg(align)              align <- match.arg(align)
244              if(align == "fancy") {              if(align == "fancy") {
# Line 246  Line 252 
252                             fi[2,] + as.logical(fi[2,] > 0),                             fi[2,] + as.logical(fi[2,] > 0),
253                             ## exponential:                             ## exponential:
254                             fi[2,] + fi[3,] + 4)                             fi[2,] + fi[3,] + 4)
255                  zero.print <- sprintf("%-*s", pad[cols] + 1, zero.print)                  ## now be efficient ; sprintf() is relatively slow
256                    ## and pad is much smaller than 'cols'; instead of "simply"
257                    ## zero.print <- sprintf("%-*s", pad[cols] + 1, zero.print)
258                    if(any(doP <- pad > 0)) {#
259                        ## only pad those that need padding - *before* expanding
260                        z.p.pad <- rep.int(zero.print, length(pad))
261                        z.p.pad[doP] <- sprintf("%-*s", pad[doP] + 1, zero.print)
262                        zero.print <- z.p.pad[cols]
263                    }
264                    else
265                        zero.print <- rep.int(zero.print, length(cols))
266              } ## else "right" : nothing to do              } ## else "right" : nothing to do
267    
268              x[-iN0] <- zero.print              x[-iN0] <- zero.print
269          } else if (ne == 0)# all zeroes          } else if (ne == 0)# all zeroes
270              x[] <- zero.print              x[] <- zero.print
271      }      }
272        if(row.trailer != '')
273            x <- cbind(x, row.trailer, deparse.level = 0)
274      ## right = TRUE : cheap attempt to get better "." alignment      ## right = TRUE : cheap attempt to get better "." alignment
275      print(x, quote = FALSE, right = TRUE, max = maxp)      print(x, quote = FALSE, right = TRUE, max = maxp)
276      invisible(object)      invisible(object)
# Line 267  Line 285 
285         if(prod(d) <= maxp)         if(prod(d) <= maxp)
286             prSpMatrix(object, maxp = maxp)             prSpMatrix(object, maxp = maxp)
287         else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:         else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:
288             nr <- maxp %/% d[2]  
            n2 <- ceiling(nr / 2)  
289             nR <- d[1] # nrow             nR <- d[1] # nrow
290             prSpMatrix(object[seq_len(min(nR, max(1, n2))), drop = FALSE])             useW <- getOption("width") - (format.info(nR)[1] + 3+1)
291             cat("\n ..........\n\n")             ##                           space for "[<last>,] "
292             prSpMatrix(object[seq(to = nR, length = min(max(1, nr-n2), nR)),             suppCols <- (d[2] * 2 > useW)
293                               drop = FALSE])             nc <- if(suppCols) (useW - (1 + 6)) %/% 2 else d[2]
294               ##                          sp+ row.trailer
295               row.trailer <- if(suppCols) "......" else ""
296               nr <- maxp %/% nc
297               suppRows <- (nr < nR)
298               if(suppRows) {
299                   if(suppCols)
300                       object <- object[ , 1:nc, drop = FALSE]
301                   n2 <- ceiling(nr / 2)
302                   prSpMatrix(object[seq_len(min(nR, max(1, n2))), , drop=FALSE],
303                              row.trailer = row.trailer)
304                   cat("\n ..............................",
305                       "\n ..........suppressing rows in show(); maybe adjust 'options(max.print= *)'",
306                       "\n ..............................\n\n", sep='')
307                   ## tail() automagically uses "[..,]" rownames:
308                   prSpMatrix(tail(object, max(1, nr-n2)),
309                              row.trailer = row.trailer)
310               }
311               else if(suppCols) {
312                   prSpMatrix(object[ , 1:nc , drop = FALSE],
313                              row.trailer = row.trailer)
314    
315                   cat("\n .....suppressing columns in show(); maybe adjust 'options(max.print= *)'",
316                       "\n ..............................\n", sep='')
317               }
318               else stop("logic programming error in prSpMatrix(), please report")
319    
320             invisible(object)             invisible(object)
321         }         }
322     })     })

Legend:
Removed from v.1736  
changed lines
  Added in v.1737

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