From: dscott Date: Fri, 15 Jan 2016 04:43:58 +0000 (+0000) Subject: Minimal working version of print.xtableFtable included. X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=441359cb797965b93707dd75054555ce0a56fad5;p=xtable.git Minimal working version of print.xtableFtable included. git-svn-id: svn://scm.r-forge.r-project.org/svnroot/xtable@95 edb9625f-4e0d-4859-8d74-9fd3b1da38cb --- diff --git a/pkg/R/xtable.R b/pkg/R/xtable.R index 39d5b19..8313808 100644 --- a/pkg/R/xtable.R +++ b/pkg/R/xtable.R @@ -78,12 +78,12 @@ xtable.table <- function(x, caption = NULL, label = NULL, align = NULL, dimnames = list(rownames(x), names(dimnames(x)))), caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, auto = auto, ...)) } else if (length(dim(x))==2) { return(xtable.matrix(matrix(x, ncol = dim(x)[2], nrow = dim(x)[1], dimnames = list(rownames(x), colnames(x))), caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, auto = auto, ...)) } else { stop("xtable.table is not implemented for tables of > 2 dimensions") } @@ -116,14 +116,14 @@ xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.anova(anova(x, ...), caption = caption, label = label, align = align, digits = digits, display = display, - auto = auto)) + auto = auto, ...)) } xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.anova(x[[1]], caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, auto = auto, ...)) } xtable.summary.aovlist <- function(x, caption = NULL, label = NULL, @@ -134,13 +134,13 @@ xtable.summary.aovlist <- function(x, caption = NULL, label = NULL, result <- xtable.summary.aov(x[[i]], caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto) + display = display, auto = auto, ...) } else { result <- rbind(result, xtable.anova(x[[i]][[1]], caption = caption, label = label, align = align, digits = digits, display = display, - auto = auto)) + auto = auto, ...)) } } return(result) @@ -150,7 +150,7 @@ xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.aovlist(summary(x), caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } @@ -160,7 +160,7 @@ xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.lm(summary(x), caption = caption, label = label, align = align, digits = digits, display = display, - auto = auto)) + auto = auto, ...)) } xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL, @@ -186,14 +186,16 @@ xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.glm(summary(x), caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, + auto = auto, ...)) } xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.lm(x, caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, + auto = auto, ...)) } @@ -253,7 +255,7 @@ xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL, c("coef", "exp(coef)", "robust se", "z", "p")) } return(xtable(tmp, caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, auto = auto, ...)) } ### Additional method: xtable.ts @@ -292,12 +294,15 @@ xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL, names(tmp) <- COLNAMES } return(xtable(tmp, caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto)) + digits = digits, display = display, auto = auto, ...)) } ### Suggested by Ajay Narottam Shah in e-mail 2006/07/22 -xtable.zoo <- function(x, ...) { - return(xtable(as.ts(x), ...)) +xtable.zoo <- function(x, caption = NULL, label = NULL, align = NULL, + digits = NULL, display = NULL, auto = FALSE, ...) { + return(xtable(as.ts(x), caption = caption, label = label, + align = align, digits = digits, + display = display, auto = auto, ...)) } ### Date: Fri, 29 May 2015 11:41:04 +0200 @@ -309,7 +314,7 @@ xtable.sarlm <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.sarlm(summary(x), caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } xtable.summary.sarlm <- function(x, caption = NULL, label = NULL, align = NULL, @@ -337,7 +342,7 @@ xtable.spautolm <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.sarlm(summary(x), caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } xtable.summary.spautolm <- function(x, caption = NULL, label = NULL, @@ -345,7 +350,7 @@ xtable.summary.spautolm <- function(x, caption = NULL, label = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.sarlm(summary(x), caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } @@ -362,7 +367,7 @@ xtable.summary.gmsar <- function(x, caption = NULL, label = NULL, align = NULL, auto = FALSE, ...) { return(xtable.summary.sarlm(x, caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } ### stsls objects @@ -378,17 +383,25 @@ xtable.summary.stsls <- function(x, caption = NULL, label = NULL, align = NULL, auto = FALSE, ...) { return(xtable.summary.sarlm(x, caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } ### pred.sarlm objects -xtable.sarlm.pred <- function(x, ...) { - return(xtable(as.data.frame(x), ...)) +xtable.sarlm.pred <- function(x, caption = NULL, label = NULL, align = NULL, + digits = NULL, display = NULL, + auto = FALSE, ...) { + return(xtable(as.data.frame(x), caption = caption, label = label, + align = align, digits = digits, + display = display, auto = auto, ...)) } ### lagImpact objects -xtable.lagImpact <- function(x, ...) { - xtable(spdep:::lagImpactMat(x), ...) +xtable.lagImpact <- function(x, caption = NULL, label = NULL, align = NULL, + digits = NULL, display = NULL, + auto = FALSE, ...) { + xtable(spdep:::lagImpactMat(x), caption = caption, label = label, + align = align, digits = digits, + display = display, auto = auto, ...) } ### package splm @@ -397,7 +410,7 @@ xtable.splm <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.splm(summary(x), caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } xtable.summary.splm <- function(x, caption = NULL, label = NULL, align = NULL, @@ -423,7 +436,7 @@ xtable.sphet <- function(x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, auto = FALSE, ...) { return(xtable.summary.splm(summary(x), caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } xtable.summary.sphet <- function(x, caption = NULL, label = NULL, align = NULL, @@ -431,5 +444,5 @@ xtable.summary.sphet <- function(x, caption = NULL, label = NULL, align = NULL, auto = FALSE, ...) { return(xtable.summary.splm(x, caption = caption, label = label, align = align, digits = digits, - display = display, auto = auto)) + display = display, auto = auto, ...)) } diff --git a/pkg/R/xtableFtable.R b/pkg/R/xtableFtable.R index 31e088b..22d721a 100644 --- a/pkg/R/xtableFtable.R +++ b/pkg/R/xtableFtable.R @@ -1,19 +1,63 @@ ### 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, + digits = NULL, display = NULL, quote = TRUE, 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) + 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 + 1 + nCharRows <- nColVars + 1 + } + if (method == "row.compact"){ + nCharCols <- nRowVars + 1 + nCharRows <- nColVars + } + if (method == "col.compact"){ + nCharCols <- nRowVars + nCharRows <- nColVars + 1 + } + if (method == "compact"){ + nCharCols <- nRowVars + nCharRows <- nColVars + } + + if(is.null(align)) align <- c(rep("l", nCharCols), 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, @@ -50,9 +94,26 @@ print.xtableFtable <- function(x, timestamp = getOption("xtable.timestamp", date()), ...) { if (type == "latex"){ - if (is.null(align) { - align <- c(rep("r", nRowVars) - } else { + 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] + fmtFtbl <- stats:::format.ftable(x, quote = quote, digits = digits, + method = method, lsep = lsep) + attr(fmtFtbl, "caption") <- caption + attr(fmtFtbl, "label") <- label + attr(fmtFtbl, "align") <- align + attr(fmtFtbl, "digits") <- digits + attr(fmtFtbl, "quote") <- quote + attr(fmtFtbl, "display") <- display + print.xtable(fmtFtbl, hline.after = c(-1, nCharRows, dim(fmtFtbl)[1]), + include.rownames = FALSE, include.colnames = FALSE) + } else { stop("print.xtableFtable not yet implemented for this type") } } diff --git a/pkg/man/xtable.Rd b/pkg/man/xtable.Rd index 9beb1a6..36caca2 100644 --- a/pkg/man/xtable.Rd +++ b/pkg/man/xtable.Rd @@ -132,22 +132,16 @@ xtable(x, caption = NULL, label = NULL, align = NULL, digits = NULL, which inherits the \code{data.frame} class and contains several additional attributes specifying the table formatting options. - In the case of the \code{xtableMatharray} method, an object of class - \code{xtableMatharray}, which the \code{xtable} and \code{data.frame} - classes and contains several additional attributes specifying the - table formatting options. - } \author{David Dahl \email{dahl@stat.byu.edu} with contributions and suggestions from many others (see source code). } -\seealso{ +\seealso{ \code{\link{print.xtable}}, \code{\link{caption}}, \code{\link{label}}, \code{\link{align}}, \code{\link{digits}}, - \code{\link{display}} - - \code{\link{autoformat}}, \code{\link{xalign}}, \code{\link{xdigits}}, - \code{\link{xdisplay}} + \code{\link{display}}, \code{\link{autoformat}}, \code{\link{xalign}}, + \code{\link{xdigits}}, \code{\link{xdisplay}}, + \code{\link{xtableMatharray}}, \codel{\link{xtableList}} } \examples{ diff --git a/pkg/tests/test.xtable.xtableFtable.R b/pkg/tests/test.xtable.xtableFtable.R index f20b8bc..473f0e7 100644 --- a/pkg/tests/test.xtable.xtableFtable.R +++ b/pkg/tests/test.xtable.xtableFtable.R @@ -5,32 +5,22 @@ library(xtable) tbl <- ftable(mtcars$cyl, mtcars$vs, mtcars$am, mtcars$gear, row.vars = c(2, 4), dnn = c("Cylinders", "V/S", "Transmission", "Gears")) -xtableFtable <- function(x, caption = NULL, label = NULL, align = NULL, - digits = NULL, quote = TRUE, - method = c("non.compact", "row.compact", - "col.compact", "compact"), - lsep = " | ", ...) { - ftbl <- stats:::format.ftable(x, quote = quote, digits = digits, - method = method, lsep = lsep) - print(unclass(xftbl)) - print(str(ftbl)) - xftbl <- xtable:::xtable.matrix(ftbl, - caption = caption, label = label, align = align, - digits = digits, display = display, auto = auto) - print(unclass(ftbl)) - print(str(xftbl)) - xftblAttr <- attributes(xftbl) - class(xftbl) <- c("matrix") - print(attributes(xftbl)) - print(attributes(ftbl)) - attributes(xftbl) <- list(names = xftblAttr$names, - row.names = xftblAttr$row.names, - class = c("xtableFtable", "matrix")) +source("../R/xtableFtable.R") - return(xftbl) -} debug(xtableFtable) xftbl <- xtableFtable(tbl) str(xftbl) unclass(xftbl) +print.xtableFtable(xftbl) +xftbl <- xtableFtable(tbl, method = "row.compact") +print.xtableFtable(xftbl) +xftbl <- xtableFtable(tbl, method = "col.compact") +print.xtableFtable(xftbl) +xftbl <- xtableFtable(tbl, method = "compact") +print.xtableFtable(xftbl) +debug(print.xtableFtable) +undebug(print.xtableFtable) +debug(print.xtable) +undebug(print.xtable) +