The R Project SVN – R-packages – Diff – /branches/Matrix-APIchange/R/sparseMatrix.R

 ### --- show() method ---
 ## FIXME(?) -- ``merge this'' (at least ``synchronize'') with
 ## - - -   prMatrix() from ./Auxiliaries.R
-prSpMatrix <- function(x, digits = getOption("digits"),
-                       maxp = getOption("max.print"), zero.print = ".",
-                       col.names = FALSE, note.dropping.colnames = TRUE,
-                       col.trailer = '', align = c("fancy", "right"))
 ## FIXME: prTriang() in ./Auxiliaries.R  should also get  align = "fancy"
+## --> help for this is currently (rudimentary) in ../man/sparseMatrix-class.Rd
+printSpMatrix <- function(x, digits = getOption("digits"),
+		       maxp = getOption("max.print"), zero.print = ".",
+		       col.names, note.dropping.colnames = TRUE,
+		       col.trailer = '', align = c("fancy", "right"))
+{
     cl <- getClassDef(class(x))
     stopifnot(extends(cl, "sparseMatrix"))
     d <- dim(x)
     if(prod(d) > maxp) { # "Large" => will be "cut"
         nr <- maxp %/% d[2]
 	m <- as(x[1:max(1, nr), ,drop=FALSE], "Matrix")
     } else {
         m <- as(x, "matrix")
+    }
+    dn <- dimnames(m) ## will be === dimnames(cx)
     logi <- extends(cl,"lsparseMatrix") || extends(cl,"nsparseMatrix")
     if(logi)
-	cx <- array("N", # or as.character(NA),
+	cx <- array("N", dim(m), dimnames=dn)
-		   dim(m), dimnames=dimnames(m))
     else { ## numeric (or --not yet-- complex):
 	cx <- apply(m, 2, format)
 	if(is.null(dim(cx))) {# e.g. in	1 x 1 case
 	    dim(cx) <- dim(m)
-	    dimnames(cx) <- dimnames(m)
+	    dimnames(cx) <- dn
+	}
+    }
-    if(!col.names)
+    if (missing(col.names))
+        col.names <- {
+            if(!is.null(cc <- getOption("sparse.colnames")))
+                cc
+            else if(is.null(dn[[2]]))
+                FALSE
+            else { # has column names == dn[[2]]
+                ncol(x) < 10
+            }
+        }
+    if(identical(col.names, FALSE))
         cx <- emptyColnames(cx, msg.if.not.empty = note.dropping.colnames)
+    else if(is.character(col.names)) {
+        stopifnot(length(col.names) == 1)
+        cn <- col.names
+        switch(substr(cn, 1,3),
+               "abb" = {
+                   iarg <- as.integer(sub("^[^0-9]*", '', cn))
+                   colnames(cx) <- abbreviate(colnames(cx), minlength = iarg)
+               },
+               "sub" = {
+                   iarg <- as.integer(sub("^[^0-9]*", '', cn))
+                   colnames(cx) <- substr(colnames(cx), 1, iarg)
+               },
+               stop("invalid 'col.names' string: ", cn))
+    }
+    ## else: nothing to do for col.names == TRUE
     if(is.logical(zero.print))
 	zero.print <- if(zero.print) "0" else " "
     if(logi) {
 	cx[!m] <- zero.print
 	cx[m] <- "|"
     ## right = TRUE : cheap attempt to get better "." alignment
     print(cx, quote = FALSE, right = TRUE, max = maxp)
     invisible(x)
+}
-setMethod("print", signature(x = "sparseMatrix"), prSpMatrix)
+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)
-	   prSpMatrix(object, maxp = maxp)
+	   printSpMatrix(object, maxp = maxp)
        else { ## d[1] > maxp / d[2] >= nr : -- this needs [,] working:
 	   nR <- d[1] # nrow
            useW <- getOption("width") - (format.info(nR)[1] + 3+1)
            ##                           space for "[<last>,] "
            suppRows <- (nr < nR)
            if(suppRows) {
 	       if(suppCols)
 		   object <- object[ , 1:nc, drop = FALSE]
 	       n2 <- ceiling(nr / 2)
-	       prSpMatrix(object[seq_len(min(nR, max(1, n2))), , drop=FALSE],
+	       printSpMatrix(object[seq_len(min(nR, max(1, n2))), , drop=FALSE],
-			  col.trailer = col.trailer)
+                             col.trailer = col.trailer)
 	       cat("\n ..............................",
 		   "\n ..........suppressing rows in show(); maybe adjust 'options(max.print= *)'",
 		   "\n ..............................\n\n", sep='')
 	       ## tail() automagically uses "[..,]" rownames:
-	       prSpMatrix(tail(object, max(1, nr-n2)),
+	       printSpMatrix(tail(object, max(1, nr-n2)),
-			  col.trailer = col.trailer)
+                             col.trailer = col.trailer)
+	   }
 	   else if(suppCols) {
-	       prSpMatrix(object[ , 1:nc , drop = FALSE],
+	       printSpMatrix(object[ , 1:nc , drop = FALSE],
-			  col.trailer = col.trailer)
+                             col.trailer = col.trailer)
 	       cat("\n .....suppressing columns in show(); maybe adjust 'options(max.print= *)'",
 		   "\n ..............................\n", sep='')
+	   }
-           else stop("logic programming error in prSpMatrix(), please report")
+           else stop("logic programming error in printSpMatrix(), please report")
            invisible(object)
+       }
    })

The R Project SVN R-packages

(root)/branches/Matrix-APIchange/R/sparseMatrix.R – Rev 4529 → 4549