>>>>> Marius Hofert <marius.hof...@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@r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-devel
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
