[Rd] Suggestion: 'method' slot for format.ftable()

[Marius Hofert]

Dear R-developers,

I would like to suggest a 'method' slot for format.ftable() (see an adjusted
'format.ftable()' below, taken from the source of R-2.15.2).

At the moment, format.ftable() contains several empty cells due to the way the
row and column labels are printed. This creates problems (= unwanted empty
columns/rows) when converting an ftable to a LaTeX table; see an example based
on 'xtable' below (I am aware of other packages that can create LaTeX
tables). It would be great to have a 'method' slot with several, more compact
versions. This would be helpful in various contexts (if required, I can provide
more details, including an adjusted .Rd).

Cheers,

Marius



##' @title Adjusted format.ftable() (based on ./src/library/stats/R/ftable.R in R-2.15.2)
##' @param x see ?format.ftable
##' @param quote see ?format.ftable
##' @param digits see ?format.ftable
##' @param method different methods of how the formatted ftable is presented;
##'        currently available are:
##'        "non.compact": the default of format.ftable()
##'        "row.compact": without empty row under the column labels
##'        "col.compact": without empty column to the right of the row labels
##'        "compact"    : without neither empty rows nor columns
##' @param sep separation character of row/col labels for method=="compact"
##' @param ... see ?format.ftable
##' @return see ?format.ftable
format.ftable <- function(x, quote=TRUE, digits=getOption("digits"),
                          method=c("non.compact", "row.compact", "col.compact", "compact"),
                          sep=" \\ ", ...)
{
    if(!inherits(x, "ftable"))
        stop("'x' must be an \"ftable\" object")
    charQuote <- function(s)
        if(quote) paste0("\"", s, "\"") else s
    makeLabels <- function(lst) {
        lens <- sapply(lst, length)
        cplensU <- c(1, cumprod(lens))
        cplensD <- rev(c(1, cumprod(rev(lens))))
        y <- NULL
        for (i in rev(seq_along(lst))) {
            ind <- 1 + seq.int(from = 0, to = lens[i] - 1) * cplensD[i + 1]
            tmp <- character(length = cplensD[i])
            tmp[ind] <- charQuote(lst[[i]])
            y <- cbind(rep(tmp, times = cplensU[i]), y)
        }
        y
    }
    makeNames <- function(x) {
        nmx <- names(x)
        if(is.null(nmx))
            nmx <- rep("", length.out = length(x))
        nmx
    }

    xrv <- attr(x, "row.vars")
    xcv <- attr(x, "col.vars")
    method <- match.arg(method)
    LABS <- switch(method,
                   "non.compact"={ # current default
                       cbind(rbind(matrix("", nrow = length(xcv), ncol = length(xrv)),
                                   charQuote(makeNames(xrv)),
                                   makeLabels(xrv)),
                             c(charQuote(makeNames(xcv)),
                               rep("", times = nrow(x) + 1)))
                   },
                   "row.compact"={ # row-compact version
                       cbind(rbind(matrix("", nrow = length(xcv)-1, ncol = length(xrv)),
                                   charQuote(makeNames(xrv)),
                                   makeLabels(xrv)),
                             c(charQuote(makeNames(xcv)),
                               rep("", times = nrow(x))))
                   },
                   "col.compact"={ # column-compact version
                       cbind(rbind(cbind(matrix("", nrow = length(xcv), ncol = length(xrv)-1),
                                         charQuote(makeNames(xcv))),
                                   charQuote(makeNames(xrv)),
                                   makeLabels(xrv)))
                   },
                   "compact"={ # fully compact version
                       l.xcv <- length(xcv)
                       l.xrv <- length(xrv)
                       xrv.nms <- makeNames(xrv)
                       xcv.nms <- makeNames(xcv)
                       mat <- cbind(rbind(cbind(matrix("", nrow = l.xcv-1, ncol = l.xrv-1),
                                                charQuote(makeNames(xcv[-l.xcv]))),
                                          charQuote(xrv.nms),
                                          makeLabels(xrv)))
                       mat[l.xcv, l.xrv] <- paste(tail(xrv.nms, 1), tail(xcv.nms, 1), sep=sep)
                       mat
                   },
                   stop("wrong method"))
    DATA <- rbind(if(length(xcv)) t(makeLabels(xcv)),
                  if(method == "non.compact" || method == "col.compact") rep("", times = ncol(x)),
                  format(unclass(x), digits = digits))
    cbind(apply(LABS, 2L, format, justify = "left"),
	  apply(DATA, 2L, format, justify = "right"))
}



## toy example
(mdat <- matrix(c(1,20,3, -40, 5, 6), nrow=2, ncol=3, byrow=TRUE,
                dimnames=list(a=c("a1", "a2"), b=c("b1", "b2", "b3"))))
ft <- ftable(mdat) # print.ftable() ~> write.ftable() ~> format.ftable()
format.ftable(ft, quote=FALSE)
format.ftable(ft, quote=FALSE, method="row.compact")
format.ftable(ft, quote=FALSE, method="col.compact")
format.ftable(ft, quote=FALSE, method="compact")

## Titanic data set
ft. <- ftable(Titanic, row.vars=1:2, col.vars=3:4)
format.ftable(ft., quote=FALSE)
format.ftable(ft., quote=FALSE, method="row.compact")
format.ftable(ft., quote=FALSE, method="col.compact")
format.ftable(ft., quote=FALSE, method="compact")

## convert to a LaTeX table via 'xtable'
require(xtable)
## current default
print(xtable(format.ftable(ft., quote=FALSE)),
             floating=FALSE, only.contents=TRUE, hline.after=NULL,
             include.rownames=FALSE, include.colnames=FALSE)
## compact version (=> does not introduce empty columns in the LaTeX table)
print(xtable(format.ftable(ft., quote=FALSE, method="compact")),
             floating=FALSE, only.contents=TRUE, hline.after=NULL,
             include.rownames=FALSE, include.colnames=FALSE)




-- 
Eth Zurich
Dr. Marius Hofert
RiskLab, Department of Mathematics
HG E 65.2
Rämistrasse 101
8092 Zurich
Switzerland

Phone +41 44 632 2423
http://www.math.ethz.ch/~hofertj
GPG key fingerprint 8EF4 5842 0EA2 5E1D 3D7F  0E34 AD4C 566E 655F 3F7C