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

[Martin Maechler]

>>>>> Marius Hofert <marius.hofert at math.ethz.ch>
>>>>>     on Mon, 17 Dec 2012 11:39:03 +0100 writes:

    > 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).

Dear Marius, this sounds interesting and relevant,
and clearly is 100% back-compatible, so I am planning to adopt
it (with very very slight changes, nothing semantic).

Yes, indeed, for the help page, please provide
a patch against the *current* version, i.e.

  https://svn.r-project.org/R/trunk/src/library/stats/man/read.ftable.Rd

Thank you for your contribution!
Regards,
Martin



    > ##' @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

    > ______________________________________________
    > R-devel at r-project.org mailing list
    > https://stat.ethz.ch/mailman/listinfo/r-devel