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