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   math.style.negative = getOption("xtable.math.style.negative", FALSE),\r
  58   html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),\r
  59   print.results = getOption("xtable.print.results", TRUE),\r
  60   format.args = getOption("xtable.format.args", NULL),\r
  61   rotate.rownames = getOption("xtable.rotate.rownames", FALSE),\r
  62   rotate.colnames = getOption("xtable.rotate.colnames", FALSE),\r
  63   booktabs = getOption("xtable.booktabs", FALSE),\r
  64   scalebox = getOption("xtable.scalebox", NULL),\r
  65   width = getOption("xtable.width", NULL),\r
  66   comment = getOption("xtable.comment", TRUE),\r
  67   timestamp = getOption("xtable.timestamp", date()),\r
  68   colnames.format = "single",\r
  69   ...)\r
  70 {\r
  71   ## Get number of rows for each table in list of tables\r
  72   nCols <- dim(x[[1]])[2]\r
  73   rowNums <- sapply(x, dim)[1,]\r
  74   combinedRowNums <- cumsum(rowNums)\r
  75   combined <- do.call(rbind, x)\r
  76   if (type == "latex"){\r
  77     ## Special treatment if using booktabs\r
  78     if (booktabs){\r
  79       tRule <- "\\toprule"\r
  80       mRule <- "\\midrule"\r
  81       bRule <- "\\bottomrule"\r
  82     } else {\r
  83       tRule <- "\\hline"\r
  84       mRule <- "\\hline"\r
  85       bRule <- "\\hline"\r
  86     }\r
  87     if (colnames.format == "single"){\r
  88       add.to.row <- list(pos = NULL, command = NULL)\r
  89       add.to.row$pos <- as.list(c(0, combinedRowNums[-length(x)],\r
  90                                   dim(combined)[1]))\r
  91       command <- sapply(x, attr, "subheading")\r
  92       \r
  93       add.to.row$command[1:length(x)] <-\r
  94         paste0(mRule,"\n\\multicolumn{", nCols, "}{l}{", command, "}\\\\\n")\r
  95       if ( (booktabs) & length(attr(x, "message") > 0) ){\r
  96         attr(x, "message")[1] <-\r
  97           paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
  98       }\r
  99       add.to.row$command[length(x) + 1] <-\r
 100         paste0("\n\\multicolumn{", nCols, "}{l}{",\r
 101                attr(x, "message"), "}\\\\\n",\r
 102                collapse = "")\r
 103       add.to.row$command[length(x) + 1] <-\r
 104         paste0(bRule, add.to.row$command[length(x) + 1])\r
 105       \r
 106       class(combined) <- c("xtableList", "data.frame")\r
 107       hline.after <- c(-1)\r
 108       include.colnames <- TRUE\r
 109     }\r
 110 \r
 111     ## Create headings for columns if multiple headings are needed\r
 112     if (colnames.format == "multiple"){\r
 113       if (is.null(sanitize.colnames.function)) {\r
 114         colHead <- names(x[[1]])\r
 115       } else {\r
 116         colHead <- sanitize.colnames.function(names(x[[1]]))\r
 117       }\r
 118       if (rotate.colnames) {\r
 119         colHead <- paste("\\begin{sideways}", colHead, "\\end{sideways}")\r
 120       }\r
 121       colHead <- paste0(colHead, collapse = " & ")\r
 122       if (include.rownames) {\r
 123         colHead <- paste0(" & ", colHead)\r
 124       }\r
 125       colHead <- paste0(tRule, "\n", colHead, " \\\\", mRule, "\n")\r
 126       add.to.row <- list(pos = NULL, command = NULL)\r
 127       add.to.row$pos <- as.list(c(0, c(combinedRowNums[1:length(x)])))\r
 128       command <- sapply(x, attr, "subheading")\r
 129       add.to.row$command[1] <-\r
 130         paste0("\n\\multicolumn{", nCols, "}{l}{", command[1], "}", " \\\\ \n",\r
 131                colHead)\r
 132       add.to.row$command[2:length(x)] <-\r
 133         paste0(bRule,\r
 134                "\\\\ \n\\multicolumn{", nCols, "}{l}{",\r
 135                command[2:length(x)], "}",\r
 136                "\\\\ \n",\r
 137                colHead)\r
 138       if ( (booktabs) & length(attr(x, "message") > 0) ){\r
 139         attr(x, "message")[1] <-\r
 140           paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
 141       }\r
 142       add.to.row$command[length(x) + 1] <-\r
 143         paste0("\n\\multicolumn{", nCols, "}{l}{",\r
 144                attr(x, "message"), "}\\\\\n",\r
 145                collapse = "")\r
 146       add.to.row$command[length(x) + 1] <-\r
 147         paste0(bRule, add.to.row$command[length(x) + 1])\r
 148       \r
 149       class(combined) <- c("xtableList", "data.frame")\r
 150       hline.after <- NULL\r
 151       \r
 152       include.colnames <- FALSE\r
 153     }\r
 154     \r
 155     print.xtable(combined,\r
 156                  type = type,\r
 157                  floating = floating,\r
 158                  floating.environment = floating.environment,\r
 159                  table.placement = table.placement,\r
 160                  caption.placement = caption.placement,\r
 161                  caption.width = caption.width,\r
 162                  latex.environments = latex.environments,\r
 163                  tabular.environment = tabular.environment,\r
 164                  size = size,\r
 165                  hline.after = hline.after,\r
 166                  NA.string = NA.string,\r
 167                  include.rownames = include.rownames,\r
 168                  include.colnames = include.colnames,\r
 169                  only.contents = only.contents,\r
 170                  add.to.row = add.to.row,\r
 171                  sanitize.text.function = sanitize.text.function,\r
 172                  sanitize.rownames.function = sanitize.rownames.function,\r
 173                  sanitize.colnames.function = sanitize.colnames.function,\r
 174                  math.style.negative = math.style.negative,\r
 175                  html.table.attributes = html.table.attributes,\r
 176                  print.results = print.results,\r
 177                  format.args = format.args,\r
 178                  rotate.rownames = rotate.rownames,\r
 179                  rotate.colnames = rotate.colnames,\r
 180                  booktabs = booktabs,\r
 181                  scalebox = scalebox,\r
 182                  width = width,\r
 183                  comment = comment,\r
 184                  timestamp = timestamp,\r
 185                  ...)\r
 186   } else {\r
 187     stop("print.xtableList not yet implemented for this type")\r
 188   }\r
 189 }\r
 190 \r
 191 \r
 192 ### Uses xtableList\r
 193 xtableLSMeans <- function(x, caption = NULL, label = NULL,\r
 194                           align = NULL, digits = NULL,\r
 195                           display = NULL, auto = FALSE,\r
 196                           ...){\r
 197   if (attr(x, "estName") == "lsmean"){\r
 198     xList <- split(x, f = x[, 2])\r
 199     for (i in 1:length(xList)){\r
 200       xList[[i]] <- as.data.frame(xList[[i]][, -2])\r
 201     }\r
 202     attr(xList, "subheadings") <-\r
 203       paste0(dimnames(x)[[2]][2], " = ", levels(x[[2]]))\r
 204     attr(xList, "message") <- c("", attr(x, "mesg"))\r
 205     xList <- xtableList(xList, caption = caption, label = label,\r
 206                         align = align, digits = digits,\r
 207                         display = display, auto = auto, ...)\r
 208   } else {\r
 209     xList <- x\r
 210     xList <- xtable.data.frame(xList, caption = caption, label = label,\r
 211                                align = align, digits = digits,\r
 212                                display = display, auto = auto, ...)\r
 213   }\r
 214   return(xList)\r
 215 }\r