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