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