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