pkg/R/xtableFtable.R

   1 ### ftable objects, requested by Charles Roosen
   2 ### Feature request #2248, 2/9/2012
   3 xtableFtable <- function(x, caption = NULL, label = NULL, align = NULL,
   4                          digits = NULL, display = NULL,
   5                          quote = TRUE,
   6                          method = c("non.compact", "row.compact",
   7                                     "col.compact", "compact"),
   8                          lsep = " | ", ...) {
   9   method <- match.arg(method)
  10   saveMethod <- method
  11   xDim <- dim(x)
  12   nRowVars <- length(attr(x, "row.vars"))
  13   nColVars <- length(attr(x, "col.vars"))
  14   if (nRowVars ==0){
  15     if (method =="col.compact"){
  16       method <- "non.compact"
  17     } else if (method == "compact"){
  18       method <- "row.compact"
  19     }
  20   }
  21   if (nColVars ==0){
  22     if (method =="row.compact"){
  23       method <- "non.compact"
  24     } else if (method == "compact"){
  25       method <- "col.compact"
  26     }
  27   }
  28   if (method == "non.compact"){
  29     nCharCols <- nRowVars + 1
  30     nCharRows <- nColVars + 1
  31   }
  32   if (method == "row.compact"){
  33     nCharCols <- nRowVars + 1
  34     nCharRows <- nColVars
  35   }
  36   if (method == "col.compact"){
  37     nCharCols <- nRowVars
  38     nCharRows <- nColVars + 1
  39   }
  40   if (method == "compact"){
  41     nCharCols <- nRowVars
  42     nCharRows <- nColVars
  43   }
  44
  45   if(is.null(align)) align <- c(rep("l", nCharCols), rep("r", xDim[2]))
  46   if(is.null(display)) {
  47     display <- c(rep("s", nCharCols), rep("d", xDim[2]))
  48   }
  49
  50   attr(x, "ftableCaption") <- caption
  51   attr(x, "ftableLabel") <- label
  52   attr(x, "ftableAlign") <- align
  53   attr(x, "ftableDigits") <- digits
  54   attr(x, "quote") <- quote
  55   attr(x, "ftableDisplay") <- display
  56   attr(x, "method") <- method
  57   attr(x, "lsep") <- lsep
  58   attr(x, "nChars") <- c(nCharRows, nCharCols)
  59   class(x) <- c("xtableFtable", "ftable")
  60   return(x)
  61 }
  62
  63 print.xtableFtable <- function(x,
  64   type = getOption("xtable.type", "latex"),
  65   file = getOption("xtable.file", ""),
  66   append = getOption("xtable.append", FALSE),
  67   floating = getOption("xtable.floating", TRUE),
  68   floating.environment = getOption("xtable.floating.environment", "table"),
  69   table.placement = getOption("xtable.table.placement", "ht"),
  70   caption.placement = getOption("xtable.caption.placement", "bottom"),
  71   caption.width = getOption("xtable.caption.width", NULL),
  72   latex.environments = getOption("xtable.latex.environments", c("center")),
  73   tabular.environment = getOption("xtable.tabular.environment", "tabular"),
  74   size = getOption("xtable.size", NULL),
  75   hline.after = getOption("xtable.hline.after", NULL),
  76   NA.string = getOption("xtable.NA.string", ""),
  77   only.contents = getOption("xtable.only.contents", FALSE),
  78   add.to.row = getOption("xtable.add.to.row", NULL),
  79   sanitize.rownames.function = getOption("xtable.sanitize.rownames.function",
  80                                          sanitize.text.function),
  81   sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",
  82                                          sanitize.text.function),
  83   math.style.negative = getOption("xtable.math.style.negative", FALSE),
  84   math.style.exponents = getOption("xtable.math.style.exponents", FALSE),
  85   html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),
  86   print.results = getOption("xtable.print.results", TRUE),
  87   format.args = getOption("xtable.format.args", NULL),
  88   rotate.rownames = getOption("xtable.rotate.rownames", FALSE),
  89   rotate.colnames = getOption("xtable.rotate.colnames", FALSE),
  90   booktabs = getOption("xtable.booktabs", FALSE),
  91   scalebox = getOption("xtable.scalebox", NULL),
  92   width = getOption("xtable.width", NULL),
  93   comment = getOption("xtable.comment", TRUE),
  94   timestamp = getOption("xtable.timestamp", date()),
  95   ...) {
  96   if (type == "latex"){
  97     caption <- attr(x, "ftableCaption")
  98     label <- attr(x, "ftableLabel")
  99     align <- attr(x, "ftableAlign")
 100     digits <- attr(x, "ftableDigits")
 101     quote <- attr(x, "quote")
 102     digits <- attr(x, "ftabelDigits")
 103     method <- attr(x, "method")
 104     lsep <- attr(x, "lsep")
 105     nCharRows <- attr(x, "nChars")[1]
 106     fmtFtbl <- stats:::format.ftable(x, quote = quote, digits = digits,
 107                                      method = method, lsep = lsep)
 108     attr(fmtFtbl, "caption") <- caption
 109     attr(fmtFtbl, "label") <- label
 110     attr(fmtFtbl, "align") <- align
 111     attr(fmtFtbl, "digits") <- digits
 112     attr(fmtFtbl, "quote") <- quote
 113     attr(fmtFtbl, "display") <- display
 114     print.xtable(fmtFtbl, hline.after = c(-1, nCharRows, dim(fmtFtbl)[1]),
 115                  include.rownames = FALSE, include.colnames = FALSE)
 116   } else {
 117     stop("print.xtableFtable not yet implemented for this type")
 118   }
 119 }
 120