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 = 0, display = NULL,
   5                          quote = FALSE,
   6                          method = c("non.compact", "row.compact",
   7                                     "col.compact", "compact"),
   8                          lsep = " $\\vert$ ", ...) {
   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 + 2
  30     nCharRows <- nColVars + 1
  31   }
  32   if (method == "row.compact"){
  33     nCharCols <- nRowVars + 2
  34     nCharRows <- nColVars
  35   }
  36   if (method == "col.compact"){
  37     nCharCols <- nRowVars + 1
  38     nCharRows <- nColVars + 1
  39   }
  40   if (method == "compact"){
  41     nCharCols <- nRowVars + 1
  42     nCharRows <- nColVars
  43   }
  44
  45   if(is.null(align)) {
  46     align <- c(rep("l", nCharCols - 1), "l |", rep("r", xDim[2]))
  47   }
  48   if(is.null(display)) {
  49     display <- c(rep("s", nCharCols), rep("d", xDim[2]))
  50   }
  51
  52   attr(x, "ftableCaption") <- caption
  53   attr(x, "ftableLabel") <- label
  54   attr(x, "ftableAlign") <- align
  55   attr(x, "ftableDigits") <- digits
  56   attr(x, "quote") <- quote
  57   attr(x, "ftableDisplay") <- display
  58   attr(x, "method") <- method
  59   attr(x, "lsep") <- lsep
  60   attr(x, "nChars") <- c(nCharRows, nCharCols)
  61   class(x) <- c("xtableFtable", "ftable")
  62   return(x)
  63 }
  64
  65 print.xtableFtable <- function(x,
  66   type = getOption("xtable.type", "latex"),
  67   file = getOption("xtable.file", ""),
  68   append = getOption("xtable.append", FALSE),
  69   floating = getOption("xtable.floating", TRUE),
  70   floating.environment = getOption("xtable.floating.environment", "table"),
  71   table.placement = getOption("xtable.table.placement", "ht"),
  72   caption.placement = getOption("xtable.caption.placement", "bottom"),
  73   caption.width = getOption("xtable.caption.width", NULL),
  74   latex.environments = getOption("xtable.latex.environments", c("center")),
  75   tabular.environment = getOption("xtable.tabular.environment", "tabular"),
  76   size = getOption("xtable.size", NULL),
  77   hline.after = getOption("xtable.hline.after", NULL),
  78   NA.string = getOption("xtable.NA.string", ""),
  79   only.contents = getOption("xtable.only.contents", FALSE),
  80   add.to.row = getOption("xtable.add.to.row", NULL),
  81   sanitize.text.function = getOption("xtable.sanitize.text.function", as.is),
  82   sanitize.rownames.function = getOption("xtable.sanitize.rownames.function",
  83                                          sanitize.text.function),
  84   sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",
  85                                          sanitize.text.function),
  86   math.style.negative = getOption("xtable.math.style.negative", FALSE),
  87   math.style.exponents = getOption("xtable.math.style.exponents", FALSE),
  88   html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),
  89   print.results = getOption("xtable.print.results", TRUE),
  90   format.args = getOption("xtable.format.args", NULL),
  91   rotate.rownames = getOption("xtable.rotate.rownames", FALSE),
  92   rotate.colnames = getOption("xtable.rotate.colnames", FALSE),
  93   booktabs = getOption("xtable.booktabs", FALSE),
  94   scalebox = getOption("xtable.scalebox", NULL),
  95   width = getOption("xtable.width", NULL),
  96   comment = getOption("xtable.comment", TRUE),
  97   timestamp = getOption("xtable.timestamp", date()),
  98   ...) {
  99   if (type == "latex"){
 100     ## extract the information in the attributes
 101     caption <- attr(x, "ftableCaption")
 102     label <- attr(x, "ftableLabel")
 103     align <- attr(x, "ftableAlign")
 104     digits <- attr(x, "ftableDigits")
 105     quote <- attr(x, "quote")
 106     digits <- attr(x, "ftabelDigits")
 107     method <- attr(x, "method")
 108     lsep <- attr(x, "lsep")
 109     nCharRows <- attr(x, "nChars")[1]
 110     nCharCols <- attr(x, "nChars")[2]
 111     nRowVars <- length(attr(x, "row.vars"))
 112     nColVars <- length(attr(x, "col.vars"))
 113
 114     ## change class so format method will find format.ftable
 115     ## even though format.ftable is not exported from 'stats'
 116     class(x) <- "ftable"
 117     fmtFtbl <- format(x, quote = quote, digits = digits,
 118                       method = method, lsep = lsep)
 119     attr(fmtFtbl, "caption") <- caption
 120     attr(fmtFtbl, "label") <- label
 121
 122     ## sanitization is possible for row names and/or column names
 123     ## row names
 124     if (is.null(sanitize.rownames.function)) {
 125       fmtFtbl[nCharRows, 1:nRowVars] <-
 126         sanitize(fmtFtbl[nCharRows, 1:nRowVars], type = type)
 127     } else {
 128       fmtFtbl[nCharRows, 1:nRowVars] <-
 129         sanitize.rownames.function(fmtFtbl[nCharRows, 1:nRowVars])
 130     }
 131     ## column names
 132     if (is.null(sanitize.colnames.function)) {
 133       fmtFtbl[1:nColVars, nCharCols - 1] <-
 134         sanitize(fmtFtbl[1:nColVars, nCharCols - 1],
 135                  type = type)
 136     } else {
 137       fmtFtbl[1:nColVars, nCharCols - 1] <-
 138         sanitize.colnames.function(fmtFtbl[1:nColVars, nCharCols - 1])
 139     }
 140     ## rotations are possible
 141     if (rotate.rownames){
 142       fmtFtbl[1:dim(fmtFtbl)[1], 1:(nCharCols - 1)] <-
 143         paste0("\\begin{sideways} ",
 144                fmtFtbl[1:dim(fmtFtbl)[1], 1:(nCharCols - 1)],
 145                "\\end{sideways}")
 146     }
 147     if (rotate.colnames){
 148       if (rotate.rownames){
 149         fmtFtbl[1:(nCharRows), (nCharCols):dim(fmtFtbl)[2]] <-
 150           paste0("\\begin{sideways} ",
 151                  fmtFtbl[1:(nCharRows), (nCharCols):dim(fmtFtbl)[2]],
 152                  "\\end{sideways}")
 153       } else {
 154         fmtFtbl[1:(nCharRows), 1:dim(fmtFtbl)[2]] <-
 155           paste0("\\begin{sideways} ",
 156                  fmtFtbl[1:(nCharRows), 1:dim(fmtFtbl)[2]],
 157                  "\\end{sideways}")
 158       }
 159     }
 160
 161
 162     ## booktabs is incompatible with vertical lines in tables
 163     if (booktabs) align <- gsub("|","", align, fixed = TRUE)
 164     attr(fmtFtbl, "align") <- align
 165     attr(fmtFtbl, "digits") <- digits
 166     attr(fmtFtbl, "quote") <- quote
 167     attr(fmtFtbl, "display") <- display
 168
 169     ## labels should be left aligned
 170     for (i in 1:nCharRows){
 171       fmtFtbl[i, nCharCols:dim(fmtFtbl)[2]] <-
 172         paste0("\\multicolumn{1}{l}{ ",
 173                fmtFtbl[i, nCharCols:dim(fmtFtbl)[2]], "}")
 174     }
 175
 176
 177     if(is.null(hline.after)) {
 178       hline.after <- c(-1, nCharRows, dim(fmtFtbl)[1])
 179     }
 180     print.xtable(fmtFtbl, hline.after = hline.after,
 181                  include.rownames = FALSE, include.colnames = FALSE,
 182                  booktabs = booktabs,
 183                  sanitize.text.function = as.is)
 184   } else {
 185     stop("print.xtableFtable not yet implemented for this type")
 186   }
 187 }
 188
 189 ## format.xtableFtable <- function(x, quote = TRUE, digits = getOption("digits"),
 190 ##                                 method = c("non.compact", "row.compact",
 191 ##                                            "col.compact", "compact"),
 192 ##                                 lsep = " | ", ...){
 193 ##   class(x) <- "ftable"
 194
 195 ##   format(x, quote = quote, digits = digits,
 196 ##          method = method, lsep = lsep, ...)
 197 ## }