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