pkg/R/xtableList.R

   1 ### Function to create lists of tables\r
   2 xtableList <- function(x, caption = NULL, label = NULL, align = NULL,\r
   3                        digits = NULL, display = NULL, ...) {\r
   4   if (is.null(digits)){\r
   5     digitsList <- vector("list", length(x))\r
   6   } else {\r
   7     if (!is.list(digits)){\r
   8       digitsList <- vector("list", length(x))\r
   9       for (i in 1:length(x)) digitsList[[i]] <- digits\r
  10     }\r
  11   }\r
  12   if (is.null(display)){\r
  13     displayList <- vector("list", length(x))\r
  14   } else {\r
  15     if (!is.list(display)){\r
  16       displayList <- vector("list", length(x))\r
  17       for (i in 1:length(x)) displayList[[i]] <- display\r
  18     }\r
  19   }\r
  20   xList <- vector("list", length(x))\r
  21   for (i in 1:length(x)){\r
  22     xList[[i]] <- xtable(x[[i]], caption = caption, label = label,\r
  23                          align = align, digits = digitsList[[i]],\r
  24                          display = displayList[[i]], ...)\r
  25     attr(xList[[i]], 'subheading') <- attr(x, 'subheadings')[[i]]\r
  26   }\r
  27   attr(xList, "message") <- attr(x, "message")\r
  28   attr(xList, "caption") <- caption\r
  29   attr(xList, "label") <- label\r
  30   class(xList) <- c("xtableList")\r
  31   return(xList)\r
  32 }\r
  33 \r
  34 print.xtableList <- function(x,\r
  35   type = getOption("xtable.type", "latex"),\r
  36   file = getOption("xtable.file", ""),\r
  37   append = getOption("xtable.append", FALSE),\r
  38   floating = getOption("xtable.floating", TRUE),\r
  39   floating.environment = getOption("xtable.floating.environment", "table"),\r
  40   table.placement = getOption("xtable.table.placement", "ht"),\r
  41   caption.placement = getOption("xtable.caption.placement", "bottom"),\r
  42   caption.width = getOption("xtable.caption.width", NULL),\r
  43   latex.environments = getOption("xtable.latex.environments", c("center")),\r
  44   tabular.environment = getOption("xtable.tabular.environment", "tabular"),\r
  45   size = getOption("xtable.size", NULL),\r
  46   hline.after = NULL,\r
  47   NA.string = getOption("xtable.NA.string", ""),\r
  48   include.rownames = getOption("xtable.include.rownames", TRUE),\r
  49   include.colnames = getOption("xtable.include.colnames", TRUE),\r
  50   only.contents = getOption("xtable.only.contents", FALSE),\r
  51   add.to.row = NULL,\r
  52   sanitize.text.function = getOption("xtable.sanitize.text.function", NULL),\r
  53   sanitize.rownames.function = getOption("xtable.sanitize.rownames.function",\r
  54                                          sanitize.text.function),\r
  55   sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",\r
  56                                          sanitize.text.function),\r
  57   sanitize.subheadings.function =\r
  58     getOption("xtable.sanitize.subheadings.function",\r
  59               sanitize.text.function),\r
  60   sanitize.message.function =\r
  61     getOption("xtable.sanitize.message.function",\r
  62               sanitize.text.function),\r
  63   math.style.negative = getOption("xtable.math.style.negative", FALSE),\r
  64   math.style.exponents = getOption("xtable.math.style.exponents", FALSE),\r
  65   html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),\r
  66   print.results = getOption("xtable.print.results", TRUE),\r
  67   format.args = getOption("xtable.format.args", NULL),\r
  68   rotate.rownames = getOption("xtable.rotate.rownames", FALSE),\r
  69   rotate.colnames = getOption("xtable.rotate.colnames", FALSE),\r
  70   booktabs = getOption("xtable.booktabs", FALSE),\r
  71   scalebox = getOption("xtable.scalebox", NULL),\r
  72   width = getOption("xtable.width", NULL),\r
  73   comment = getOption("xtable.comment", TRUE),\r
  74   timestamp = getOption("xtable.timestamp", date()),\r
  75   colnames.format = "single",\r
  76   ...)\r
  77 {\r
  78   ## Get number of rows for each table in list of tables\r
  79   nCols <- dim(x[[1]])[2]\r
  80   rowNums <- sapply(x, dim)[1,]\r
  81   combinedRowNums <- cumsum(rowNums)\r
  82   combined <- do.call(rbind, x)\r
  83   if (type == "latex"){\r
  84     ## Special treatment if using booktabs\r
  85     if (booktabs){\r
  86       tRule <- "\\toprule"\r
  87       mRule <- "\\midrule"\r
  88       bRule <- "\\bottomrule"\r
  89     } else {\r
  90       tRule <- "\\hline"\r
  91       mRule <- "\\hline"\r
  92       bRule <- "\\hline"\r
  93     }\r
  94     ## Sanitize subheadings if required\r
  95     if (!is.null(sanitize.subheadings.function)) {\r
  96       for (i in 1:length(x)){\r
  97         attr(x[[i]], 'subheading') <-\r
  98           sanitize.subheadings.function(attr(x[[i]], 'subheading'))\r
  99       }\r
 100     }\r
 101     ## Sanitize message if required\r
 102     if (!is.null(sanitize.message.function)) {\r
 103       xMessage <- attr(x, 'message')\r
 104       xMessage <- sapply(xMessage, sanitize.message.function)\r
 105       attr(x, 'message') <- xMessage\r
 106     }    \r
 107     if (colnames.format == "single"){\r
 108  \r
 109       add.to.row <- list(pos = NULL, command = NULL)\r
 110       add.to.row$pos <- as.list(c(0, combinedRowNums[-length(x)],\r
 111                                   dim(combined)[1]))\r
 112       command <- sapply(x, attr, "subheading")\r
 113       \r
 114       add.to.row$command[1:length(x)] <-\r
 115         paste0(mRule,"\n\\multicolumn{", nCols, "}{l}{", command, "}\\\\\n")\r
 116       if ( (booktabs) & length(attr(x, "message") > 0) ){\r
 117         attr(x, "message")[1] <-\r
 118           paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
 119       }\r
 120       add.to.row$command[length(x) + 1] <-\r
 121         paste0("\n\\multicolumn{", nCols, "}{l}{",\r
 122                attr(x, "message"), "}\\\\\n",\r
 123                collapse = "")\r
 124       add.to.row$command[length(x) + 1] <-\r
 125         paste0(bRule, add.to.row$command[length(x) + 1])\r
 126       \r
 127       class(combined) <- c("xtableList", "data.frame")\r
 128       hline.after <- c(-1)\r
 129       include.colnames <- TRUE\r
 130     }\r
 131 \r
 132     ## Create headings for columns if multiple headings are needed\r
 133     if (colnames.format == "multiple"){\r
 134       if (is.null(sanitize.colnames.function)) {\r
 135         colHead <- names(x[[1]])\r
 136       } else {\r
 137         colHead <- sanitize.colnames.function(names(x[[1]]))\r
 138       }\r
 139       if (rotate.colnames) {\r
 140         colHead <- paste("\\begin{sideways}", colHead, "\\end{sideways}")\r
 141       }\r
 142       colHead <- paste0(colHead, collapse = " & ")\r
 143       if (include.rownames) {\r
 144         colHead <- paste0(" & ", colHead)\r
 145       }\r
 146       colHead <- paste0(tRule, "\n", colHead, " \\\\", mRule, "\n")\r
 147       add.to.row <- list(pos = NULL, command = NULL)\r
 148       add.to.row$pos <- as.list(c(0, c(combinedRowNums[1:length(x)])))\r
 149       command <- sapply(x, attr, "subheading")\r
 150       add.to.row$command[1] <-\r
 151         paste0("\n\\multicolumn{", nCols, "}{l}{", command[1], "}", " \\\\ \n",\r
 152                colHead)\r
 153       add.to.row$command[2:length(x)] <-\r
 154         paste0(bRule,\r
 155                "\\\\ \n\\multicolumn{", nCols, "}{l}{",\r
 156                command[2:length(x)], "}",\r
 157                "\\\\ \n",\r
 158                colHead)\r
 159       if ( (booktabs) & length(attr(x, "message") > 0) ){\r
 160         attr(x, "message")[1] <-\r
 161           paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
 162       }\r
 163       add.to.row$command[length(x) + 1] <-\r
 164         paste0("\n\\multicolumn{", nCols, "}{l}{",\r
 165                attr(x, "message"), "}\\\\\n",\r
 166                collapse = "")\r
 167       add.to.row$command[length(x) + 1] <-\r
 168         paste0(bRule, add.to.row$command[length(x) + 1])\r
 169       \r
 170       class(combined) <- c("xtableList", "data.frame")\r
 171       hline.after <- NULL\r
 172       \r
 173       include.colnames <- FALSE\r
 174     }\r
 175     \r
 176     print.xtable(combined,\r
 177                  type = type,\r
 178                  floating = floating,\r
 179                  floating.environment = floating.environment,\r
 180                  table.placement = table.placement,\r
 181                  caption.placement = caption.placement,\r
 182                  caption.width = caption.width,\r
 183                  latex.environments = latex.environments,\r
 184                  tabular.environment = tabular.environment,\r
 185                  size = size,\r
 186                  hline.after = hline.after,\r
 187                  NA.string = NA.string,\r
 188                  include.rownames = include.rownames,\r
 189                  include.colnames = include.colnames,\r
 190                  only.contents = only.contents,\r
 191                  add.to.row = add.to.row,\r
 192                  sanitize.text.function = sanitize.text.function,\r
 193                  sanitize.rownames.function = sanitize.rownames.function,\r
 194                  sanitize.colnames.function = sanitize.colnames.function,\r
 195                  math.style.negative = math.style.negative,\r
 196                  math.style.exponents = math.style.exponents,\r
 197                  html.table.attributes = html.table.attributes,\r
 198                  print.results = print.results,\r
 199                  format.args = format.args,\r
 200                  rotate.rownames = rotate.rownames,\r
 201                  rotate.colnames = rotate.colnames,\r
 202                  booktabs = booktabs,\r
 203                  scalebox = scalebox,\r
 204                  width = width,\r
 205                  comment = comment,\r
 206                  timestamp = timestamp,\r
 207                  ...)\r
 208   } else {\r
 209     stop("print.xtableList not yet implemented for this type")\r
 210   }\r
 211 }\r
 212 \r
 213 \r
 214 ### Uses xtableList\r
 215 xtableLSMeans <- function(x, caption = NULL, label = NULL,\r
 216                           align = NULL, digits = NULL,\r
 217                           display = NULL, auto = FALSE,\r
 218                           ...){\r
 219   if (attr(x, "estName") == "lsmean"){\r
 220     xList <- split(x, f = x[, 2])\r
 221     for (i in 1:length(xList)){\r
 222       xList[[i]] <- as.data.frame(xList[[i]][, -2])\r
 223     }\r
 224     attr(xList, "subheadings") <-\r
 225       paste0(dimnames(x)[[2]][2], " = ", levels(x[[2]]))\r
 226     attr(xList, "message") <- c("", attr(x, "mesg"))\r
 227     xList <- xtableList(xList, caption = caption, label = label,\r
 228                         align = align, digits = digits,\r
 229                         display = display, auto = auto, ...)\r
 230   } else {\r
 231     xList <- x\r
 232     xList <- xtable.data.frame(xList, caption = caption, label = label,\r
 233                                align = align, digits = digits,\r
 234                                display = display, auto = auto, ...)\r
 235   }\r
 236   return(xList)\r
 237 }\r