### ftable objects, requested by Charles Roosen
### Feature request #2248, 2/9/2012
xtableFtable <- function(x, caption = NULL, label = NULL, align = NULL,
- digits = NULL, display = NULL, auto = FALSE,
- quote = TRUE,
+ digits = 0, display = NULL,
+ quote = FALSE,
method = c("non.compact", "row.compact",
"col.compact", "compact"),
- lsep = " | ", ...) {
- ftbl <- format.ftable(x, quote = quote, digits = digits,
- method = method, lsep = lsep)
- xftbl <- xtable.matrix(ftbl,
- caption = caption, label = label, align = align,
- digits = digits, display = display, auto = auto)
- class(xftbl) <- c("xtableFtable", "data.frame")
- attributes(xftbl) <- list(attributes(xftbl), attributes(ftbl))
- return(xftbl)
+ lsep = " $\\vert$ ", ...) {
+ method <- match.arg(method)
+ saveMethod <- method
+ xDim <- dim(x)
+ nRowVars <- length(attr(x, "row.vars"))
+ nColVars <- length(attr(x, "col.vars"))
+ if (nRowVars == 0){
+ if (method =="col.compact"){
+ method <- "non.compact"
+ } else if (method == "compact"){
+ method <- "row.compact"
+ }
+ }
+ if (nColVars == 0){
+ if (method =="row.compact"){
+ method <- "non.compact"
+ } else if (method == "compact"){
+ method <- "col.compact"
+ }
+ }
+ if (method == "non.compact"){
+ nCharCols <- nRowVars + 2
+ nCharRows <- nColVars + 1
+ }
+ if (method == "row.compact"){
+ nCharCols <- nRowVars + 2
+ nCharRows <- nColVars
+ }
+ if (method == "col.compact"){
+ nCharCols <- nRowVars + 1
+ nCharRows <- nColVars + 1
+ }
+ if (method == "compact"){
+ nCharCols <- nRowVars + 1
+ nCharRows <- nColVars
+ }
+
+ if(is.null(align)) {
+ align <- c(rep("l", nCharCols - 1), "l |", rep("r", xDim[2]))
+ }
+ if(is.null(display)) {
+ display <- c(rep("s", nCharCols), rep("d", xDim[2]))
+ }
+
+ attr(x, "ftableCaption") <- caption
+ attr(x, "ftableLabel") <- label
+ attr(x, "ftableAlign") <- align
+ attr(x, "ftableDigits") <- digits
+ attr(x, "quote") <- quote
+ attr(x, "ftableDisplay") <- display
+ attr(x, "method") <- method
+ attr(x, "lsep") <- lsep
+ attr(x, "nChars") <- c(nCharRows, nCharCols)
+ class(x) <- c("xtableFtable", "ftable")
+ return(x)
}
-
+
print.xtableFtable <- function(x,
type = getOption("xtable.type", "latex"),
file = getOption("xtable.file", ""),
latex.environments = getOption("xtable.latex.environments", c("center")),
tabular.environment = getOption("xtable.tabular.environment", "tabular"),
size = getOption("xtable.size", NULL),
- hline.after = getOption("xtable.hline.after", c(-1,0,nrow(x))),
+ hline.after = getOption("xtable.hline.after", NULL),
NA.string = getOption("xtable.NA.string", ""),
only.contents = getOption("xtable.only.contents", FALSE),
add.to.row = getOption("xtable.add.to.row", NULL),
- sanitize.text.function = getOption("xtable.sanitize.text.function", NULL),
+ sanitize.text.function = getOption("xtable.sanitize.text.function", as.is),
+ sanitize.rownames.function = getOption("xtable.sanitize.rownames.function",
+ sanitize.text.function),
+ sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",
+ sanitize.text.function),
math.style.negative = getOption("xtable.math.style.negative", FALSE),
math.style.exponents = getOption("xtable.math.style.exponents", FALSE),
html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),
print.results = getOption("xtable.print.results", TRUE),
format.args = getOption("xtable.format.args", NULL),
+ rotate.rownames = getOption("xtable.rotate.rownames", FALSE),
+ rotate.colnames = getOption("xtable.rotate.colnames", FALSE),
booktabs = getOption("xtable.booktabs", FALSE),
scalebox = getOption("xtable.scalebox", NULL),
width = getOption("xtable.width", NULL),
timestamp = getOption("xtable.timestamp", date()),
...) {
if (type == "latex"){
- if (is.null(align) {
- align <- c(rep("r", nRowVars)
+ ## extract the information in the attributes
+ caption <- attr(x, "ftableCaption")
+ label <- attr(x, "ftableLabel")
+ align <- attr(x, "ftableAlign")
+ digits <- attr(x, "ftableDigits")
+ quote <- attr(x, "quote")
+ digits <- attr(x, "ftabelDigits")
+ method <- attr(x, "method")
+ lsep <- attr(x, "lsep")
+ nCharRows <- attr(x, "nChars")[1]
+ nCharCols <- attr(x, "nChars")[2]
+ nRowVars <- length(attr(x, "row.vars"))
+ nColVars <- length(attr(x, "col.vars"))
+
+ ## change class so format method will find format.ftable
+ ## even though format.ftable is not exported from 'stats'
+ class(x) <- "ftable"
+ fmtFtbl <- format(x, quote = quote, digits = digits,
+ method = method, lsep = lsep)
+ attr(fmtFtbl, "caption") <- caption
+ attr(fmtFtbl, "label") <- label
+
+ ## sanitization is possible for row names and/or column names
+ ## row names
+ if (is.null(sanitize.rownames.function)) {
+ fmtFtbl[nCharRows, 1:nRowVars] <-
+ sanitize(fmtFtbl[nCharRows, 1:nRowVars], type = type)
+ } else {
+ fmtFtbl[nCharRows, 1:nRowVars] <-
+ sanitize.rownames.function(fmtFtbl[nCharRows, 1:nRowVars])
+ }
+ ## column names
+ if (is.null(sanitize.colnames.function)) {
+ fmtFtbl[1:nColVars, nCharCols - 1] <-
+ sanitize(fmtFtbl[1:nColVars, nCharCols - 1],
+ type = type)
} else {
+ fmtFtbl[1:nColVars, nCharCols - 1] <-
+ sanitize.colnames.function(fmtFtbl[1:nColVars, nCharCols - 1])
+ }
+ ## rotations are possible
+ if (rotate.rownames){
+ fmtFtbl[1:dim(fmtFtbl)[1], 1:(nCharCols - 1)] <-
+ paste0("\\begin{sideways} ",
+ fmtFtbl[1:dim(fmtFtbl)[1], 1:(nCharCols - 1)],
+ "\\end{sideways}")
+ }
+ if (rotate.colnames){
+ if (rotate.rownames){
+ fmtFtbl[1:(nCharRows), (nCharCols):dim(fmtFtbl)[2]] <-
+ paste0("\\begin{sideways} ",
+ fmtFtbl[1:(nCharRows), (nCharCols):dim(fmtFtbl)[2]],
+ "\\end{sideways}")
+ } else {
+ fmtFtbl[1:(nCharRows), 1:dim(fmtFtbl)[2]] <-
+ paste0("\\begin{sideways} ",
+ fmtFtbl[1:(nCharRows), 1:dim(fmtFtbl)[2]],
+ "\\end{sideways}")
+ }
+ }
+
+
+ ## booktabs is incompatible with vertical lines in tables
+ if (booktabs) align <- gsub("|","", align, fixed = TRUE)
+ attr(fmtFtbl, "align") <- align
+ attr(fmtFtbl, "digits") <- digits
+ attr(fmtFtbl, "quote") <- quote
+ attr(fmtFtbl, "display") <- display
+
+ ## labels should be left aligned
+ for (i in 1:nCharRows){
+ fmtFtbl[i, nCharCols:dim(fmtFtbl)[2]] <-
+ paste0("\\multicolumn{1}{l}{ ",
+ fmtFtbl[i, nCharCols:dim(fmtFtbl)[2]], "}")
+ }
+
+
+ if(is.null(hline.after)) {
+ hline.after <- c(-1, nCharRows, dim(fmtFtbl)[1])
+ }
+ print.xtable(fmtFtbl, hline.after = hline.after,
+ include.rownames = FALSE, include.colnames = FALSE,
+ booktabs = booktabs,
+ sanitize.text.function = as.is,
+ file = file,
+ append = append,
+ floating = floating,
+ floating.environment = floating.environment,
+ table.placement = table.placement,
+ caption.placement = caption.placement,
+ caption.width = caption.width,
+ latex.environments = latex.environments,
+ tabular.environment = tabular.environment,
+ size = size,
+ NA.string = NA.string,
+ only.contents = only.contents,
+ add.to.row = add.to.row,,
+ math.style.negative = math.style.negative,
+ math.style.exponents = math.style.exponents,
+ print.results = print.results,
+ format.args = format.args,
+ scalebox = scalebox,
+ width = width,
+ comment = comment,
+ timestamp = timestamp,
+ ...)
+ } else {
stop("print.xtableFtable not yet implemented for this type")
}
}
-
+
projects / xtable.git / blobdiff