pkg/R/print.xtable.R

   1 ### xtable package\r
   2 ###\r
   3 ### Produce LaTeX and HTML tables from R objects.\r
   4 ###\r
   5 ### Copyright 2000-2013 David B. Dahl <dahl@stat.byu.edu>\r
   6 ###\r
   7 ### Maintained by David Scott <d.scott@auckland.ac.nz>\r
   8 ###\r
   9 ### This file is part of the `xtable' library for R and related languages.\r
  10 ### It is made available under the terms of the GNU General Public\r
  11 ### License, version 2, or at your option, any later version,\r
  12 ### incorporated herein by reference.\r
  13 ###\r
  14 ### This program is distributed in the hope that it will be\r
  15 ### useful, but WITHOUT ANY WARRANTY; without even the implied\r
  16 ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
  17 ### PURPOSE.  See the GNU General Public License for more\r
  18 ### details.\r
  19 ###\r
  20 ### You should have received a copy of the GNU General Public\r
  21 ### License along with this program; if not, write to the Free\r
  22 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,\r
  23 ### MA 02111-1307, USA\r
  24 print.xtable <- function(x,\r
  25   type = getOption("xtable.type", "latex"),\r
  26   file = getOption("xtable.file", ""),\r
  27   append = getOption("xtable.append", FALSE),\r
  28   floating = getOption("xtable.floating", TRUE),\r
  29   floating.environment = getOption("xtable.floating.environment", "table"),\r
  30   table.placement = getOption("xtable.table.placement", "ht"),\r
  31   caption.placement = getOption("xtable.caption.placement", "bottom"),\r
  32   caption.width = getOption("xtable.caption.width", NULL),\r
  33   latex.environments = getOption("xtable.latex.environments", c("center")),\r
  34   tabular.environment = getOption("xtable.tabular.environment", "tabular"),\r
  35   size = getOption("xtable.size", NULL),\r
  36   hline.after = getOption("xtable.hline.after", c(-1,0,nrow(x))),\r
  37   NA.string = getOption("xtable.NA.string", ""),\r
  38   include.rownames = getOption("xtable.include.rownames", TRUE),\r
  39   include.colnames = getOption("xtable.include.colnames", TRUE),\r
  40   only.contents = getOption("xtable.only.contents", FALSE),\r
  41   add.to.row = getOption("xtable.add.to.row", NULL),\r
  42   sanitize.text.function = getOption("xtable.sanitize.text.function", NULL),\r
  43   sanitize.rownames.function = getOption("xtable.sanitize.rownames.function",\r
  44                                          sanitize.text.function),\r
  45   sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",\r
  46                                          sanitize.text.function),\r
  47   math.style.negative = getOption("xtable.math.style.negative", FALSE),\r
  48   math.style.exponents = getOption("xtable.math.style.exponents", FALSE),\r
  49   html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),\r
  50   print.results = getOption("xtable.print.results", TRUE),\r
  51   format.args = getOption("xtable.format.args", NULL),\r
  52   rotate.rownames = getOption("xtable.rotate.rownames", FALSE),\r
  53   rotate.colnames = getOption("xtable.rotate.colnames", FALSE),\r
  54   booktabs = getOption("xtable.booktabs", FALSE),\r
  55   scalebox = getOption("xtable.scalebox", NULL),\r
  56   width = getOption("xtable.width", NULL),\r
  57   comment = getOption("xtable.comment", TRUE),\r
  58   timestamp = getOption("xtable.timestamp", date()),\r
  59   ...)\r
  60 {\r
  61   ## If caption is length 2, treat the second value as the "short caption"\r
  62   caption <- attr(x,"caption",exact = TRUE)\r
  63   short.caption <- NULL\r
  64   if (!is.null(caption) && length(caption) > 1){\r
  65     short.caption <- caption[2]\r
  66     caption <- caption[1]\r
  67   }\r
  68 \r
  69   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after\r
  70   ## By default it print an \hline before and after the columns names\r
  71   ## independently they are printed or not and at the end of the table\r
  72   ## Old code that set hline.after should include c(-1, 0, nrow(x)) in the\r
  73   ## hline.after vector\r
  74   ## If you do not want any \hline inside the data, set hline.after to NULL\r
  75   ## PHEADER instead the string '\\hline\n' is used in the code\r
  76   ## Now hline.after counts how many time a position appear\r
  77   ## I left an automatic PHEADER in the longtable is this correct?\r
  78   \r
  79   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.rownames,\r
  80   ## include.colnames\r
  81   pos <- 0\r
  82   if (include.rownames) pos <- 1\r
  83   \r
  84   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
  85   ## hline.after checks\r
  86   if (any(hline.after < -1) | any(hline.after > nrow(x))) {\r
  87     stop("'hline.after' must be inside [-1, nrow(x)]")\r
  88   }\r
  89   \r
  90   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
  91   ## add.to.row checks\r
  92   if (!is.null(add.to.row)) {\r
  93     if (is.list(add.to.row) && length(add.to.row) == 2) {\r
  94       if (is.null(names(add.to.row))) {\r
  95         names(add.to.row) <- c('pos', 'command')\r
  96       } else if (any(sort(names(add.to.row))!= c('command', 'pos'))) {\r
  97         stop("the names of the elements of 'add.to.row' must be 'pos' and 'command'")\r
  98       }\r
  99       if (is.list(add.to.row$pos) && is.vector(add.to.row$command,\r
 100                                                mode = 'character')) {\r
 101         if ((npos <- length(add.to.row$pos)) !=\r
 102             length(add.to.row$command)) {\r
 103           stop("the length of 'add.to.row$pos' must be equal to the length of 'add.to.row$command'")\r
 104         }\r
 105         if (any(unlist(add.to.row$pos) < -1) |\r
 106             any(unlist(add.to.row$pos) > nrow(x))) {\r
 107           stop("the values in add.to.row$pos must be inside the interval [-1, nrow(x)]")\r
 108         }\r
 109       } else {\r
 110         stop("the first argument ('pos') of 'add.to.row' must be a list, the second argument ('command') must be a vector of mode character")\r
 111       }\r
 112     } else {\r
 113       stop("'add.to.row' argument must be a list of length 2")\r
 114     }\r
 115   } else {\r
 116     add.to.row <- list(pos = list(),\r
 117                        command = vector(length = 0, mode = "character"))\r
 118     npos <- 0\r
 119   }\r
 120   \r
 121   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row\r
 122   ## Add further commands at the end of rows\r
 123   if (type == "latex") {\r
 124     ## Original code before changes in version 1.6-1\r
 125     ## PHEADER <- "\\hline\n"\r
 126     \r
 127     ## booktabs code from Matthieu Stigler <matthieu.stigler@gmail.com>,\r
 128     ## 1 Feb 2012\r
 129     if(!booktabs){\r
 130       PHEADER <- "\\hline\n"\r
 131     } else {\r
 132       ## This code replaced to fix bug #2309, David Scott, 8 Jan 2014\r
 133       ## PHEADER <- ifelse(-1%in%hline.after, "\\toprule\n", "")\r
 134       ## if(0%in%hline.after) {\r
 135       ##     PHEADER <- c(PHEADER, "\\midrule\n")\r
 136       ## }\r
 137       ## if(nrow(x)%in%hline.after) {\r
 138       ##     PHEADER <- c(PHEADER, "\\bottomrule\n")\r
 139       ## }\r
 140       if (is.null(hline.after)){\r
 141         PHEADER <- ""\r
 142       } else {\r
 143         hline.after <- sort(hline.after)\r
 144         PHEADER <- rep("\\midrule\n", length(hline.after))\r
 145         if (hline.after[1] == -1) {\r
 146           PHEADER[1] <- "\\toprule\n"\r
 147         }\r
 148         if (hline.after[length(hline.after)] == nrow(x)) {\r
 149           PHEADER[length(hline.after)] <- "\\bottomrule\n"\r
 150         }\r
 151       }\r
 152     }\r
 153   } else {\r
 154     PHEADER <- ""\r
 155   }\r
 156   \r
 157   lastcol <- rep(" ", nrow(x)+2)\r
 158   if (!is.null(hline.after)) {\r
 159     ## booktabs change - Matthieu Stigler: fill the hline arguments\r
 160     ## separately, 1 Feb 2012\r
 161     ##\r
 162     ## Code before booktabs change was:\r
 163     ##    add.to.row$pos[[npos+1]] <- hline.after\r
 164     \r
 165     if (!booktabs){\r
 166       add.to.row$pos[[npos+1]] <- hline.after\r
 167     } else {\r
 168       for(i in 1:length(hline.after)) {\r
 169         add.to.row$pos[[npos+i]] <- hline.after[i]\r
 170       }\r
 171     }\r
 172     add.to.row$command <- c(add.to.row$command, PHEADER)\r
 173   }\r
 174   \r
 175   if ( length(add.to.row$command) > 0 ) {\r
 176     for (i in 1:length(add.to.row$command)) {\r
 177       addpos <- add.to.row$pos[[i]]\r
 178       freq <- table(addpos)\r
 179       addpos <- unique(addpos)\r
 180       for (j in 1:length(addpos)) {\r
 181         lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2],\r
 182                                       paste(rep(add.to.row$command[i],\r
 183                                                 freq[j]),\r
 184                                             sep = "", collapse = ""),\r
 185                                       sep = " ")\r
 186       }\r
 187     }\r
 188   }\r
 189   \r
 190   if (length(type)>1) stop("\"type\" must have length 1")\r
 191   type <- tolower(type)\r
 192   if (!all(!is.na(match(type, c("latex","html"))))) {\r
 193     stop("\"type\" must be in {\"latex\", \"html\"}")\r
 194   }\r
 195   ## Disabling the check on known floating environments as many users\r
 196   ## want to use additional environments.\r
 197   ##    if (!all(!is.na(match(floating.environment,\r
 198   ##                          c("table","table*","sidewaystable",\r
 199   ##                            "margintable"))))) {\r
 200   ##        stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}")\r
 201   ##    }\r
 202   if (("margintable" %in% floating.environment)\r
 203       & (!is.null(table.placement))) {\r
 204     warning("margintable does not allow for table placement; setting table.placement to NULL")\r
 205     table.placement <- NULL\r
 206   }\r
 207   if (!is.null(table.placement) &&\r
 208       !all(!is.na(match(unlist(strsplit(table.placement,  split = "")),\r
 209                         c("H","h","t","b","p","!"))))) {\r
 210     stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")\r
 211   }\r
 212   if (!all(!is.na(match(caption.placement, c("bottom","top"))))) {\r
 213     stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")\r
 214   }\r
 215   \r
 216   if (type == "latex") {\r
 217     BCOMMENT <- "% "\r
 218     ECOMMENT <- "\n"\r
 219     ## See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003\r
 220     ## regarding "texfloat"\r
 221     ## See e-mail form "Fernando Henrique Ferraz P. da Rosa"\r
 222     ## <academic@feferraz.net>" dated 10-28-2005 regarding "longtable"\r
 223     if ( tabular.environment == "longtable" & floating == TRUE ) {\r
 224       warning("Attempt to use \"longtable\" with floating = TRUE. Changing to FALSE.")\r
 225       floating <- FALSE\r
 226     }\r
 227     if ( floating == TRUE ) {\r
 228       ## See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>"\r
 229       ## dated 7-09-2003 regarding "suggestion for an amendment of\r
 230       ## the source"\r
 231       ## See e-mail from "Mitchell, David"\r
 232       ## <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding\r
 233       ## "Additions to R xtable package"\r
 234       ## See e-mail from "Garbade, Sven"\r
 235       ## <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22\r
 236       ## regarding the floating environment.\r
 237       BTABLE <- paste("\\begin{", floating.environment, "}",\r
 238                       ifelse(!is.null(table.placement),\r
 239                              paste("[", table.placement, "]", sep = ""),\r
 240                              ""), "\n", sep = "")\r
 241       if ( is.null(latex.environments) ||\r
 242            (length(latex.environments) == 0) ) {\r
 243         BENVIRONMENT <- ""\r
 244         EENVIRONMENT <- ""\r
 245       } else {\r
 246         BENVIRONMENT <- ""\r
 247         EENVIRONMENT <- ""\r
 248         if ("center" %in% latex.environments){\r
 249           BENVIRONMENT <- paste(BENVIRONMENT, "\\centering\n",\r
 250                                 sep = "")\r
 251         }\r
 252         for (i in 1:length(latex.environments)) {\r
 253           if (latex.environments[i] == "") next\r
 254           if (latex.environments[i] != "center"){\r
 255             BENVIRONMENT <- paste(BENVIRONMENT,\r
 256                                   "\\begin{", latex.environments[i],\r
 257                                   "}\n", sep = "")\r
 258             EENVIRONMENT <- paste("\\end{", latex.environments[i],\r
 259                                   "}\n", EENVIRONMENT, sep = "")\r
 260           }\r
 261         }\r
 262       }\r
 263       ETABLE <- paste("\\end{", floating.environment, "}\n", sep = "")\r
 264     } else {\r
 265       BTABLE <- ""\r
 266       ETABLE <- ""\r
 267       BENVIRONMENT <- ""\r
 268       EENVIRONMENT <- ""\r
 269     }\r
 270     \r
 271     tmp.index.start <- 1\r
 272     if ( ! include.rownames ) {\r
 273       while ( attr(x, "align", exact = TRUE)[tmp.index.start] == '|' )\r
 274         tmp.index.start <- tmp.index.start + 1\r
 275       tmp.index.start <- tmp.index.start + 1\r
 276     }\r
 277     ## Added "width" argument for use with "tabular*" or\r
 278     ## "tabularx" environments - CR, 7/2/12\r
 279     if (is.null(width)){\r
 280       WIDTH <-""\r
 281     } else if (is.element(tabular.environment,\r
 282                           c("tabular", "longtable"))){\r
 283       warning("Ignoring 'width' argument.  The 'tabular' and 'longtable' environments do not support a width specification.  Use another environment such as 'tabular*' or 'tabularx' to specify the width.")\r
 284       WIDTH <- ""\r
 285     } else {\r
 286       WIDTH <- paste("{", width, "}", sep = "")\r
 287     }\r
 288     \r
 289     BTABULAR <-\r
 290       paste("\\begin{", tabular.environment, "}",\r
 291             WIDTH, "{",\r
 292             paste(c(attr(x, "align",\r
 293                          exact = TRUE)[\r
 294               tmp.index.start:length(attr(x, "align",\r
 295                                           exact = TRUE))],\r
 296               "}\n"),\r
 297               sep = "", collapse = ""),\r
 298             sep = "")\r
 299     \r
 300     ## fix 10-26-09 (robert.castelo@upf.edu) the following\r
 301     ## 'if' condition is added here to support\r
 302     ## a caption on the top of a longtable\r
 303     if (tabular.environment == "longtable" && caption.placement == "top") {\r
 304       if (is.null(short.caption)){\r
 305         BCAPTION <- "\\caption{"\r
 306       } else {\r
 307         BCAPTION <- paste("\\caption[", short.caption, "]{", sep = "")\r
 308       }\r
 309       ECAPTION <- "} \\\\ \n"\r
 310       if ((!is.null(caption)) && (type == "latex")) {\r
 311         BTABULAR <- paste(BTABULAR,  BCAPTION, caption, ECAPTION,\r
 312                           sep = "")\r
 313       }\r
 314     }\r
 315     ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
 316     ## add.to.row position -1\r
 317     BTABULAR <- paste(BTABULAR, lastcol[1], sep = "")\r
 318     ## the \hline at the end, if present, is set in full matrix\r
 319     ETABULAR <- paste("\\end{", tabular.environment, "}\n", sep = "")\r
 320     \r
 321     ## Add scalebox - CR, 7/2/12\r
 322     if (!is.null(scalebox)){\r
 323       BTABULAR <- paste("\\scalebox{", scalebox, "}{\n", BTABULAR,\r
 324                         sep = "")\r
 325       ETABULAR <- paste(ETABULAR, "}\n", sep = "")\r
 326     }\r
 327     \r
 328     ## BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail\r
 329     ## dated Wednesday, December 01, 2004\r
 330     if (is.null(size) || !is.character(size)) {\r
 331       BSIZE <- ""\r
 332       ESIZE <- ""\r
 333     } else {\r
 334       if(length(grep("^\\\\", size)) == 0){\r
 335         size <- paste("\\", size, sep = "")\r
 336       }\r
 337       ## Change suggested by Claudius Loehnert reported in Bug #6260\r
 338       ## BSIZE <- paste("{", size, "\n", sep = "")\r
 339       ## ESIZE <- "{\n"\r
 340       BSIZE <- paste("\\begingroup", size, "\n", sep = "")\r
 341       ESIZE <- "\\endgroup\n"\r
 342     }\r
 343     BLABEL <- "\\label{"\r
 344     ELABEL <- "}\n"\r
 345     ## Added caption width (jeff.laake@nooa.gov)\r
 346     if(!is.null(caption.width)){\r
 347       BCAPTION <- paste("\\parbox{",caption.width,"}{",sep="")\r
 348       ECAPTION <- "}"\r
 349     } else {\r
 350       BCAPTION <- NULL\r
 351       ECAPTION <- NULL\r
 352     }\r
 353     if (is.null(short.caption)){\r
 354       BCAPTION <- paste(BCAPTION,"\\caption{",sep="")\r
 355     } else {\r
 356       BCAPTION <- paste(BCAPTION,"\\caption[", short.caption, "]{", sep="")\r
 357     }\r
 358     ECAPTION <- paste(ECAPTION,"} \n",sep="")\r
 359     BROW <- ""\r
 360     EROW <- " \\\\ \n"\r
 361     BTH <- ""\r
 362     ETH <- ""\r
 363     STH <- " & "\r
 364     BTD1 <- " & "\r
 365     BTD2 <- ""\r
 366     BTD3 <- ""\r
 367     ETD  <- ""\r
 368     } else {\r
 369       BCOMMENT <- "<!-- "\r
 370       ECOMMENT <- " -->\n"\r
 371       BTABLE <- paste("<table ", html.table.attributes, ">\n", sep = "")\r
 372       ETABLE <- "</table>\n"\r
 373       BENVIRONMENT <- ""\r
 374       EENVIRONMENT <- ""\r
 375       BTABULAR <- ""\r
 376       ETABULAR <- ""\r
 377       BSIZE <- ""\r
 378       ESIZE <- ""\r
 379       BLABEL <- "<a name="\r
 380       ELABEL <- "></a>\n"\r
 381       BCAPTION <- paste("<caption align=\"", caption.placement, "\"> ",\r
 382                         sep = "")\r
 383       ECAPTION <- " </caption>\n"\r
 384       BROW <- "<tr>"\r
 385       EROW <- " </tr>\n"\r
 386       BTH <- " <th> "\r
 387       ETH <- " </th> "\r
 388       STH <- " </th> <th> "\r
 389       BTD1 <- " <td align=\""\r
 390       align.tmp <- attr(x, "align", exact = TRUE)\r
 391       align.tmp <- align.tmp[align.tmp!="|"]\r
 392       if (nrow(x) == 0) {\r
 393         BTD2 <- matrix(nrow = 0, ncol = ncol(x)+pos)\r
 394       } else {\r
 395         BTD2 <- matrix(align.tmp[(2-pos):(ncol(x)+1)],\r
 396                        nrow = nrow(x), ncol = ncol(x)+pos, byrow = TRUE)\r
 397       }\r
 398       ## Based on contribution from Jonathan Swinton <jonathan@swintons.net>\r
 399       ## in e-mail dated Wednesday, January 17, 2007\r
 400       BTD2[regexpr("^p", BTD2)>0] <- "left"\r
 401       BTD2[BTD2 == "r"] <- "right"\r
 402       BTD2[BTD2 == "l"] <- "left"\r
 403       BTD2[BTD2 == "c"] <- "center"\r
 404       BTD3 <- "\"> "\r
 405       ETD  <- " </td>"\r
 406     }\r
 407   \r
 408   result <- string("", file = file, append = append)\r
 409   info <- R.Version()\r
 410   ## modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
 411   ## to set automatically the package version\r
 412   if (comment){\r
 413     result <- result + BCOMMENT + type + " table generated in " +\r
 414       info$language + " " + info$major + "." + info$minor +\r
 415       " by xtable " +  packageDescription('xtable')$Version +\r
 416                                                   " package" + ECOMMENT\r
 417     if (!is.null(timestamp)){\r
 418       result <- result + BCOMMENT + timestamp + ECOMMENT\r
 419     }\r
 420   }\r
 421   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents\r
 422   if (!only.contents) {\r
 423     result <- result + BTABLE\r
 424     result <- result + BENVIRONMENT\r
 425     if ( floating == TRUE ) {\r
 426       if ((!is.null(caption)) &&\r
 427           (type == "html" ||caption.placement == "top")) {\r
 428         result <- result + BCAPTION + caption + ECAPTION\r
 429       }\r
 430       if (!is.null(attr(x, "label", exact = TRUE)) &&\r
 431           (type == "latex" && caption.placement == "top")) {\r
 432         result <- result + BLABEL +\r
 433           attr(x, "label", exact = TRUE) + ELABEL\r
 434       }\r
 435     }\r
 436     result <- result + BSIZE\r
 437     result <- result + BTABULAR\r
 438   }\r
 439   ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
 440   ## include.colnames, include.rownames\r
 441   if (include.colnames) {\r
 442     COLNAMES <- string("", file = file, append = append)\r
 443     COLNAMES <- COLNAMES + BROW + BTH\r
 444     if (include.rownames) {\r
 445       COLNAMES <- COLNAMES + STH\r
 446     }\r
 447     ## David G. Whiting in e-mail 2007-10-09\r
 448     if (is.null(sanitize.colnames.function)) {\r
 449       CNAMES <- sanitize(names(x), type = type)\r
 450     } else {\r
 451       CNAMES <- sanitize.colnames.function(names(x))\r
 452     }\r
 453     if (rotate.colnames) {\r
 454       ##added by Markus Loecher, 2009-11-16\r
 455       CNAMES <- paste("\\begin{sideways}", CNAMES, "\\end{sideways}")\r
 456     }\r
 457     COLNAMES <- COLNAMES + paste(CNAMES, collapse = STH)\r
 458     \r
 459     COLNAMES <- COLNAMES + ETH + EROW\r
 460     result <- result + COLNAMES\r
 461     if (tabular.environment=="longtable") {\r
 462         result <- result + "\\endfirsthead\n"\r
 463         if (booktabs) {\r
 464             if (!is.null(caption)) {\r
 465                 result <- result + "\\caption[]{"+caption+"} \\\\\n"\r
 466             }\r
 467             result <- result + "\\toprule\n"+ COLNAMES + "\\midrule\n\\endhead\n"\r
 468         } else {\r
 469             if (!is.null(caption)) {\r
 470                 result <- result + "\\caption[]{"+caption+"}\n"\r
 471             }\r
 472             result <- result + COLNAMES + "\\endhead\n"\r
 473         }\r
 474     }\r
 475   }\r
 476   cols <- matrix("", nrow = nrow(x), ncol = ncol(x)+pos)\r
 477   if (include.rownames) {\r
 478     ## David G. Whiting in e-mail 2007-10-09\r
 479     if (is.null(sanitize.rownames.function)) {\r
 480       RNAMES <- sanitize(row.names(x), type = type)\r
 481     } else {\r
 482       RNAMES <- sanitize.rownames.function(row.names(x))\r
 483     }\r
 484     if (rotate.rownames) {\r
 485       ##added by Markus Loecher, 2009-11-16\r
 486       RNAMES <- paste("\\begin{sideways}", RNAMES, "\\end{sideways}")\r
 487     }\r
 488     cols[, 1] <- RNAMES\r
 489   }\r
 490 \r
 491   ## Begin vectorizing the formatting code by Ian Fellows [ian@fellstat.com]\r
 492   ## 06 Dec 2011\r
 493   ##\r
 494   ##  disp <- function(y) {\r
 495   ##    if (is.factor(y)) {\r
 496   ##      y <- levels(y)[y]\r
 497   ##    }\r
 498   ##    if (is.list(y)) {\r
 499   ##      y <- unlist(y)\r
 500   ##    }\r
 501   ##    return(y)\r
 502   ##  }\r
 503   varying.digits <- is.matrix( attr( x, "digits", exact = TRUE ) )\r
 504   ## Code for letting "digits" be a matrix was provided by\r
 505   ## Arne Henningsen <ahenningsen@agric-econ.uni-kiel.de>\r
 506   ## in e-mail dated 2005-06-04.\r
 507   ##if( !varying.digits ) {\r
 508   ## modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
 509   ##  attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ),\r
 510   ## nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )\r
 511   ##}\r
 512   for(i in 1:ncol(x)) {\r
 513     xcol <- x[, i]\r
 514     if(is.factor(xcol))\r
 515       xcol <- as.character(xcol)\r
 516     if(is.list(xcol))\r
 517       xcol <- sapply(xcol, unlist)\r
 518     ina <- is.na(xcol)\r
 519     is.numeric.column <- is.numeric(xcol)\r
 520     \r
 521     if(is.character(xcol)) {\r
 522       cols[, i+pos] <- xcol\r
 523     } else {\r
 524       if (is.null(format.args)){\r
 525         format.args <- list()\r
 526       }\r
 527       if (is.null(format.args$decimal.mark)){\r
 528         format.args$decimal.mark <- options()$OutDec\r
 529       }\r
 530       if(!varying.digits){\r
 531         curFormatArgs <-\r
 532           c(list(\r
 533             x = xcol,\r
 534             format =\r
 535               ifelse(attr(x, "digits", exact = TRUE )[i+1] < 0, "E",\r
 536                      attr(x, "display", exact = TRUE )[i+1]),\r
 537             digits = abs(attr(x, "digits", exact = TRUE )[i+1])),\r
 538             format.args)\r
 539         cols[, i+pos] <- do.call("formatC", curFormatArgs)\r
 540       }else{\r
 541         for( j in 1:nrow( cols ) ) {\r
 542           curFormatArgs <-\r
 543             c(list(\r
 544               x = xcol[j],\r
 545               format =\r
 546                 ifelse(attr(x, "digits", exact = TRUE )[j, i+1] < 0,\r
 547                        "E", attr(x, "display", exact = TRUE )[i+1]),\r
 548               digits =\r
 549                 abs(attr(x, "digits", exact = TRUE )[j, i+1])),\r
 550               format.args)\r
 551           cols[j, i+pos] <- do.call("formatC", curFormatArgs)\r
 552         }\r
 553       }\r
 554     }\r
 555     ## End Ian Fellows changes\r
 556 \r
 557     if ( any(ina) ) cols[ina, i+pos] <- NA.string\r
 558     ## Based on contribution from Jonathan Swinton <jonathan@swintons.net>\r
 559     ## in e-mail dated Wednesday, January 17, 2007\r
 560     if ( is.numeric.column ) {\r
 561       cols[, i+pos] <-\r
 562         sanitize.numbers(cols[, i+pos], type = type,\r
 563                          math.style.negative = math.style.negative,\r
 564                          math.style.exponents = math.style.exponents)\r
 565     } else {\r
 566       if (is.null(sanitize.text.function)) {\r
 567         cols[, i+pos] <- sanitize(cols[, i+pos], type = type)\r
 568       } else {\r
 569         cols[, i+pos] <- sanitize.text.function(cols[, i+pos])\r
 570       }\r
 571     }\r
 572   }\r
 573   \r
 574   multiplier <- 5\r
 575   full <- matrix("", nrow = nrow(x), ncol = multiplier*(ncol(x)+pos)+2)\r
 576   full[, 1] <- BROW\r
 577   full[, multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1\r
 578   full[, multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2\r
 579   full[, multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3\r
 580   full[, multiplier*(0:(ncol(x)+pos-1))+5] <- cols\r
 581   full[, multiplier*(0:(ncol(x)+pos-1))+6] <- ETD\r
 582   \r
 583   full[, multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)],\r
 584                                               sep = " ")\r
 585   \r
 586   if (type == "latex") full[, 2] <- ""\r
 587   result <- result + lastcol[2] + paste(t(full), collapse = "")\r
 588   if (!only.contents) {\r
 589     if (tabular.environment == "longtable") {\r
 590       ## booktabs change added the if() - 1 Feb 2012\r
 591       if(!booktabs) {\r
 592         result <- result + PHEADER\r
 593       }\r
 594 \r
 595       ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the\r
 596       ## following 'if' condition is inserted in order to avoid\r
 597       ## that bottom caption interferes with a top caption of a longtable\r
 598       if(caption.placement == "bottom"){\r
 599         if ((!is.null(caption)) && (type == "latex")) {\r
 600           result <- result + BCAPTION + caption + ECAPTION\r
 601         }\r
 602       }\r
 603       if (!is.null(attr(x, "label", exact = TRUE))) {\r
 604         result <- result + BLABEL + attr(x, "label", exact = TRUE) +\r
 605           ELABEL\r
 606       }\r
 607       ETABULAR <- "\\end{longtable}\n"\r
 608     }\r
 609     result <- result + ETABULAR\r
 610     result <- result + ESIZE\r
 611     if ( floating == TRUE ) {\r
 612       if ((!is.null(caption)) &&\r
 613           (type == "latex" && caption.placement == "bottom")) {\r
 614         result <- result + BCAPTION + caption + ECAPTION\r
 615       }\r
 616       if (!is.null(attr(x, "label", exact = TRUE)) &&\r
 617           caption.placement == "bottom") {\r
 618         result <- result + BLABEL + attr(x, "label", exact = TRUE) +\r
 619           ELABEL\r
 620       }\r
 621     }\r
 622     result <- result + EENVIRONMENT\r
 623     result <- result + ETABLE\r
 624   }\r
 625   result <- sanitize.final(result, type = type)\r
 626   \r
 627   if (print.results){\r
 628     print(result)\r
 629   }\r
 630   \r
 631   return(invisible(result$text))\r
 632 }\r
 633 \r
 634 "+.string" <- function(x, y) {\r
 635   x$text <- paste(x$text, as.string(y)$text, sep = "")\r
 636   return(x)\r
 637 }\r
 638 \r
 639 print.string <- function(x, ...) {\r
 640   cat(x$text, file = x$file, append = x$append)\r
 641   return(invisible())\r
 642 }\r
 643 \r
 644 string <- function(text, file = "", append = FALSE) {\r
 645   x <- list(text = text, file = file, append = append)\r
 646   class(x) <- "string"\r
 647   return(x)\r
 648 }\r
 649 \r
 650 as.string <- function(x, file = "", append = FALSE) {\r
 651   if (is.null(attr(x, "class", exact = TRUE)))\r
 652     switch(data.class(x),\r
 653            character = return(string(x, file, append)),\r
 654            numeric = return(string(as.character(x), file, append)),\r
 655            stop("Cannot coerce argument to a string"))\r
 656   if (class(x) == "string")\r
 657     return(x)\r
 658   stop("Cannot coerce argument to a string")\r
 659 }\r
 660 \r
 661 is.string <- function(x) {\r
 662   return(class(x) == "string")\r
 663 }\r
 664 \r