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 39d5b190890011c48d0a80bda57e4e7692e5d685..83138088887c4472bc0c22a617c2701ef0c751b3 100644 (file)
--- 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 <ajayshah@mayin.org> 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 31e088bd36e2e2ee3108aab3c7c688bfac82b983..22d721a03ca5786abaa0b9d96968d640fb40d204 100644 (file)
--- 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 9beb1a64f876fac9f5330976771c8d6e4b87d223..36caca2c7bb55dcedbfa5133744262cc40435aa6 100644 (file)
--- 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 f20b8bccb838ef3ae5ddfe20e989adff7361f097..473f0e73e6dfd5fc211e416745f796b1e2d04586 100644 (file)
--- 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)
+