pkg/R/print.xtable.R

   1 ### xtable package
   2 ###
   3 ### Produce LaTeX and HTML tables from R objects.
   4 ###
   5 ### Copyright 2000-2007 David B. Dahl <dahl@stat.tamu.edu>
   6 ###
   7 ### This file is part of the `xtable' library for R and related languages.
   8 ### It is made available under the terms of the GNU General Public
   9 ### License, version 2, or at your option, any later version,
  10 ### incorporated herein by reference.
  11 ###
  12 ### This program is distributed in the hope that it will be
  13 ### useful, but WITHOUT ANY WARRANTY; without even the implied
  14 ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15 ### PURPOSE.  See the GNU General Public License for more
  16 ### details.
  17 ###
  18 ### You should have received a copy of the GNU General Public
  19 ### License along with this program; if not, write to the Free
  20 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21 ### MA 02111-1307, USA
  22 print.xtable <- function(
  23   x,
  24   type="latex",
  25   file="",
  26   append=FALSE,
  27   floating=TRUE,
  28   floating.environment="table",
  29   table.placement="ht",
  30   caption.placement="bottom",
  31   latex.environments=c("center"),
  32   tabular.environment="tabular",
  33   size=NULL,
  34   hline.after=c(-1,0,nrow(x)),
  35   NA.string="",
  36   include.rownames=TRUE,
  37   include.colnames=TRUE,
  38   only.contents=FALSE,
  39   add.to.row=NULL,
  40   sanitize.text.function=NULL,
  41   sanitize.rownames.function=sanitize.text.function,
  42   sanitize.colnames.function=sanitize.text.function,
  43   math.style.negative=FALSE,
  44   html.table.attributes="border=1",
  45   ...) {
  46   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after
  47   # 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
  48   # Old code that set hline.after should include c(-1, 0, nrow(x)) in the hline.after vector
  49   # If you do not want any \hline inside the data, set hline.after to NULL
  50   # PHEADER instead the string '\\hline\n' is used in the code
  51   # Now hline.after counts how many time a position appear
  52   # I left an automatic PHEADER in the longtable is this correct?
  53
  54   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.rownames, include.colnames
  55   pos <- 0
  56   if (include.rownames) pos <- 1
  57
  58   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after checks
  59   if (any(hline.after < -1) | any(hline.after > nrow(x))) stop("'hline.after' must be inside [-1, nrow(x)]")
  60
  61   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row checks
  62   if (!is.null(add.to.row)) {
  63     if (is.list(add.to.row) && length(add.to.row)==2) {
  64       if (is.null(names(add.to.row))) {
  65         names(add.to.row) <- c('pos', 'command')
  66       } else if (any(sort(names(add.to.row))!=c('command', 'pos'))) {
  67         stop("the names of the elements of 'add.to.row' must be 'pos' and 'command'")
  68       }
  69       if (is.list(add.to.row$pos) && is.vector(add.to.row$command, mode='character')) {
  70         if ((npos <- length(add.to.row$pos)) != length(add.to.row$command)) {
  71           stop("the length of 'add.to.row$pos' must be equal to the length of 'add.to.row$command'")
  72         }
  73         if (any(unlist(add.to.row$pos) < -1) | any(unlist(add.to.row$pos) > nrow(x))) {
  74           stop("the values in add.to.row$pos must be inside the interval [-1, nrow(x)]")
  75         }
  76       } else {
  77         stop("the first argument ('pos') of 'add.to.row' must be a list, the second argument ('command') must be a vector of mode character")
  78       }
  79     } else {
  80       stop("'add.to.row' argument must be a list of length 2")
  81     }
  82   } else {
  83      add.to.row <- list(pos=list(), command=vector(length=0, mode="character"))
  84      npos <- 0
  85   }
  86
  87   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row
  88   # Add further commands at the end of rows
  89   if (type=="latex") {
  90      PHEADER <- "\\hline\n"
  91   } else {
  92      PHEADER <- ""
  93   }
  94
  95   lastcol <- rep(" ", nrow(x)+2)
  96   if (!is.null(hline.after)) {
  97      add.to.row$pos[[npos+1]] <- hline.after
  98      add.to.row$command <- c(add.to.row$command, PHEADER)
  99   }
 100   if ( length(add.to.row$command) > 0 ) {
 101     for (i in 1:length(add.to.row$command)) {
 102       addpos <- add.to.row$pos[[i]]
 103       freq <- table(addpos)
 104       addpos <- unique(addpos)
 105       for (j in 1:length(addpos)) {
 106         lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2], paste(rep(add.to.row$command[i], freq[j]), sep="", collapse=""), sep=" ")
 107       }
 108     }
 109   }
 110
 111   if (length(type)>1) stop("\"type\" must have length 1")
 112   type <- tolower(type)
 113   if (!all(!is.na(match(type,c("latex","html"))))) stop("\"type\" must be in {\"latex\", \"html\"}")
 114   if (!all(!is.na(match(floating.environment,c("table","sidewaystable"))))) stop("\"type\" must be in {\"table\", \"sidewaystable\"}")
 115   if (!all(!is.na(match(unlist(strsplit(table.placement, split="")),c("H","h","t","b","p","!"))))) {
 116     stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")
 117   }
 118   if (!all(!is.na(match(caption.placement,c("bottom","top"))))) stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")
 119
 120   if (type=="latex") {
 121     BCOMMENT <- "% "
 122     ECOMMENT <- "\n"
 123     # See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003 regarding "texfloat"
 124     # See e-mail form "Fernando Henrique Ferraz P. da Rosa" <academic@feferraz.net>" dated 10-28-2005 regarding "longtable"
 125     if ( tabular.environment == "longtable" & floating == TRUE ) {
 126       warning("Attempt to use \"longtable\" with floating=TRUE. Changing to FALSE.")
 127       floating <- FALSE
 128     }
 129     if ( floating == TRUE ) {
 130       # See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>" dated 7-09-2003 regarding "suggestion for an amendment of the source"
 131       # See e-mail from "Mitchell, David" <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding "Additions to R xtable package"
 132       # See e-mail from "Garbade, Sven" <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22 regarding the floating environment.
 133       BTABLE <- paste("\\begin{", floating.environment, "}",ifelse(!is.null(table.placement),
 134         paste("[",table.placement,"]",sep=""),""),"\n",sep="")
 135       if ( is.null(latex.environments) || (length(latex.environments)==0) ) {
 136         BENVIRONMENT <- ""
 137         EENVIRONMENT <- ""
 138       }
 139       else {
 140         BENVIRONMENT <- ""
 141         EENVIRONMENT <- ""
 142         for ( i in 1:length(latex.environments) ) {
 143           if ( latex.environments[i] == "" ) next
 144           BENVIRONMENT <- paste(BENVIRONMENT, "\\begin{",latex.environments[i],"}\n",sep="")
 145           EENVIRONMENT <- paste("\\end{",latex.environments[i],"}\n",EENVIRONMENT,sep="")
 146         }
 147       }
 148       ETABLE <- paste("\\end{", floating.environment, "}\n", sep="")
 149     }
 150     else {
 151       BTABLE <- ""
 152       ETABLE <- ""
 153       BENVIRONMENT <- ""
 154       EENVIRONMENT <- ""
 155     }
 156
 157     tmp.index.start <- 1
 158     if ( ! include.rownames ) {
 159       while ( attr(x,"align",exact=TRUE)[tmp.index.start] == '|' ) tmp.index.start <- tmp.index.start + 1
 160       tmp.index.start <- tmp.index.start + 1
 161     }
 162     BTABULAR <- paste("\\begin{",tabular.environment,"}{",
 163                       paste(c(attr(x, "align",exact=TRUE)[tmp.index.start:length(attr(x,"align",exact=TRUE))], "}\n"),
 164                             sep="", collapse=""),
 165                       sep="")
 166
 167     ## fix 10-26-09 (robert.castelo@upf.edu) the following 'if' condition is added here to support
 168     ## a caption on the top of a longtable
 169     if (tabular.environment == "longtable" && caption.placement=="top") {
 170         BCAPTION <- "\\caption{"
 171         ECAPTION <- "} \\\\ \n"
 172         if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) BTABULAR <- paste(BTABULAR,  BCAPTION, attr(x,"caption",exact=TRUE), ECAPTION, sep="")
 173     }
 174     # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row position -1
 175     BTABULAR <- paste(BTABULAR,lastcol[1], sep="")
 176     # the \hline at the end, if present, is set in full matrix
 177     ETABULAR <- paste("\\end{",tabular.environment,"}\n",sep="")
 178
 179     # BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail dated Wednesday, December 01, 2004
 180     if (is.null(size) || !is.character(size)) {
 181       BSIZE <- ""
 182       ESIZE <- ""
 183     } else {
 184       if(length(grep("^\\\\",size))==0){
 185         size <- paste("\\",size,sep="")
 186       }
 187       BSIZE <- paste("{",size,"\n",sep="")
 188       ESIZE <- "}\n"
 189     }
 190     BLABEL <- "\\label{"
 191     ELABEL <- "}\n"
 192     BCAPTION <- "\\caption{"
 193     ECAPTION <- "}\n"
 194     BROW <- ""
 195     EROW <- " \\\\ \n"
 196     BTH <- ""
 197     ETH <- ""
 198     STH <- " & "
 199     BTD1 <- " & "
 200     BTD2 <- ""
 201     BTD3 <- ""
 202     ETD  <- ""
 203     # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
 204     sanitize <- function(str) {
 205       result <- str
 206       result <- gsub("\\\\","SANITIZE.BACKSLASH",result)
 207       result <- gsub("$","\\$",result,fixed=TRUE)
 208       result <- gsub(">","$>$",result,fixed=TRUE)
 209       result <- gsub("<","$<$",result,fixed=TRUE)
 210       result <- gsub("|","$|$",result,fixed=TRUE)
 211       result <- gsub("{","\\{",result,fixed=TRUE)
 212       result <- gsub("}","\\}",result,fixed=TRUE)
 213       result <- gsub("%","\\%",result,fixed=TRUE)
 214       result <- gsub("&","\\&",result,fixed=TRUE)
 215       result <- gsub("_","\\_",result,fixed=TRUE)
 216       result <- gsub("#","\\#",result,fixed=TRUE)
 217       result <- gsub("^","\\verb|^|",result,fixed=TRUE)
 218       result <- gsub("~","\\~{}",result,fixed=TRUE)
 219       result <- gsub("SANITIZE.BACKSLASH","$\\backslash$",result,fixed=TRUE)
 220       return(result)
 221     }
 222     sanitize.numbers <- function(x) {
 223       result <- x
 224       if ( math.style.negative ) {
 225         # Jake Bowers <jwbowers@illinois.edu> in e-mail from 2008-08-20 suggested
 226         # disabling this feature to avoid problems with LaTeX's dcolumn package.
 227         # by Florian Wickelmaier <florian.wickelmaier@uni-tuebingen.de> in e-mail
 228         # from 2008-10-03 requested the ability to use the old behavior.
 229         for(i in 1:length(x)) {
 230           result[i] <- gsub("-","$-$",result[i],fixed=TRUE)
 231         }
 232       }
 233       return(result)
 234     }
 235     sanitize.final <- function(result) {
 236       return(result)
 237     }
 238   } else {
 239     BCOMMENT <- "<!-- "
 240     ECOMMENT <- " -->\n"
 241     BTABLE <- paste("<TABLE ",html.table.attributes,">\n",sep="")
 242     ETABLE <- "</TABLE>\n"
 243     BENVIRONMENT <- ""
 244     EENVIRONMENT <- ""
 245     BTABULAR <- ""
 246     ETABULAR <- ""
 247     BSIZE <- ""
 248     ESIZE <- ""
 249     BLABEL <- "<A NAME="
 250     ELABEL <- "></A>\n"
 251     BCAPTION <- paste("<CAPTION ALIGN=\"",caption.placement,"\"> ",sep="")
 252     ECAPTION <- " </CAPTION>\n"
 253     BROW <- "<TR>"
 254     EROW <- " </TR>\n"
 255     BTH <- " <TH> "
 256     ETH <- " </TH> "
 257     STH <- " </TH> <TH> "
 258     BTD1 <- " <TD align=\""
 259     align.tmp <- attr(x,"align",exact=TRUE)
 260     align.tmp <- align.tmp[align.tmp!="|"]
 261     BTD2 <- matrix(align.tmp[(2-pos):(ncol(x)+1)],nrow=nrow(x),ncol=ncol(x)+pos,byrow=TRUE)
 262     # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
 263     BTD2[regexpr("^p",BTD2)>0] <- "left"
 264     BTD2[BTD2=="r"] <- "right"
 265     BTD2[BTD2=="l"] <- "left"
 266     BTD2[BTD2=="c"] <- "center"
 267     BTD3 <- "\"> "
 268     ETD  <- " </TD>"
 269     sanitize <- function(str) {
 270       result <- str
 271       result <- gsub("&","&amp ",result,fixed=TRUE)
 272       result <- gsub(">","&gt ",result,fixed=TRUE)
 273       result <- gsub("<","&lt ",result,fixed=TRUE)
 274       # Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05 recommended not escaping underscores.
 275       # result <- gsub("_", "\\_", result, fixed=TRUE)
 276       return(result)
 277     }
 278     sanitize.numbers <- function(x) {
 279       return(x)
 280     }
 281     sanitize.final <- function(result) {
 282       # Suggested by Uwe Ligges <ligges@statistik.uni-dortmund.de> in e-mail dated 2005-07-30.
 283       result$text <- gsub("  *"," ", result$text,fixed=TRUE)
 284       result$text <- gsub(' align="left"', "", result$text,fixed=TRUE)
 285       return(result)
 286     }
 287   }
 288
 289   result <- string("",file=file,append=append)
 290   info <- R.Version()
 291   # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 to set automatically the package version
 292   result <- result + BCOMMENT + type + " table generated in " +
 293             info$language + " " + info$major + "." + info$minor + " by xtable " + packageDescription('xtable')$Version + " package" + ECOMMENT
 294   result <- result + BCOMMENT + date() + ECOMMENT
 295   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents
 296   if (!only.contents) {
 297     result <- result + BTABLE
 298     result <- result + BENVIRONMENT
 299     if ( floating == TRUE ) {
 300       if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="html" || caption.placement=="top")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
 301       if (!is.null(attr(x,"label",exact=TRUE)) && (type=="latex" && caption.placement=="top")) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
 302     }
 303     result <- result + BSIZE
 304     result <- result + BTABULAR
 305   }
 306   # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.colnames, include.rownames
 307   if (include.colnames) {
 308     result <- result + BROW + BTH
 309     if (include.rownames) result <- result + STH
 310     if (is.null(sanitize.colnames.function)) {                                     # David G. Whiting in e-mail 2007-10-09
 311       result <- result + paste(sanitize(names(x)),collapse=STH)
 312     } else {
 313       result <- result + paste(sanitize.colnames.function(names(x)), collapse=STH) # David G. Whiting in e-mail 2007-10-09
 314     }
 315     result <- result + ETH + EROW
 316   }
 317
 318   cols <- matrix("",nrow=nrow(x),ncol=ncol(x)+pos)
 319   if (include.rownames) {
 320     if (is.null(sanitize.rownames.function)) {                                     # David G. Whiting in e-mail 2007-10-09
 321       cols[,1] <- sanitize(row.names(x))
 322     } else {
 323       cols[,1] <- sanitize.rownames.function(row.names(x))                         # David G. Whiting in e-mail 2007-10-09
 324     }
 325   }
 326
 327   disp <- function(y) {
 328     if (is.factor(y)) {
 329       y <- levels(y)[y]
 330     }
 331     if (is.list(y)) {
 332       y <- unlist(y)
 333     }
 334     return(y)
 335   }
 336   # 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.
 337   if( !is.matrix( attr( x, "digits",exact=TRUE ) ) ) {
 338     # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28
 339     attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ), nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )
 340   }
 341   for(i in 1:ncol(x)) {
 342     ina <- is.na(x[,i])
 343     is.numeric.column <- is.numeric(x[,i])
 344     for( j in 1:nrow( cols ) ) {
 345       ### modified Claudio Agostinelli <claudio@unive.it> dated 2009-09-14
 346       ### add decimal.mark=options()$OutDec
 347       cols[j,i+pos] <-
 348         formatC( disp( x[j,i] ),
 349           format = ifelse( attr( x, "digits",exact=TRUE )[j,i+1] < 0, "E", attr( x, "display",exact=TRUE )[i+1] ), digits = abs( attr( x, "digits",exact=TRUE )[j,i+1] ), decimal.mark=options()$OutDec)
 350     }
 351     if ( any(ina) ) cols[ina,i+pos] <- NA.string
 352     # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
 353     if ( is.numeric.column ) {
 354       cols[,i+pos] <- sanitize.numbers(cols[,i+pos])
 355     } else {
 356       if (is.null(sanitize.text.function)) {
 357         cols[,i+pos] <- sanitize(cols[,i+pos])
 358       } else {
 359         cols[,i+pos] <- sanitize.text.function(cols[,i+pos])
 360       }
 361     }
 362   }
 363
 364   multiplier <- 5
 365   full <- matrix("",nrow=nrow(x),ncol=multiplier*(ncol(x)+pos)+2)
 366   full[,1] <- BROW
 367   full[,multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1
 368   full[,multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2
 369   full[,multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3
 370   full[,multiplier*(0:(ncol(x)+pos-1))+5] <- cols
 371   full[,multiplier*(0:(ncol(x)+pos-1))+6] <- ETD
 372
 373   full[,multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)], sep=" ")
 374   if (type=="latex") full[,2] <- ""
 375   result <- result + lastcol[2] + paste(t(full),collapse="")
 376   if (!only.contents) {
 377     if (tabular.environment == "longtable") {
 378       result <- result + PHEADER
 379       ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the following 'if' condition is inserted in order to avoid
 380       ## that bottom caption interferes with a top caption of a longtable
 381       if(caption.placement=="bottom"){
 382         if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
 383       }
 384       if (!is.null(attr(x,"label",exact=TRUE))) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
 385       ETABULAR <- "\\end{longtable}\n"
 386     }
 387     result <- result + ETABULAR
 388     result <- result + ESIZE
 389     if ( floating == TRUE ) {
 390       if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex" && caption.placement=="bottom")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
 391       if (!is.null(attr(x,"label",exact=TRUE)) && caption.placement=="bottom") result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
 392     }
 393     result <- result + EENVIRONMENT
 394     result <- result + ETABLE
 395   }
 396   result <- sanitize.final(result)
 397   print(result)
 398
 399   return(invisible(result$text))
 400 }
 401
 402 "+.string" <- function(x,y) {
 403   x$text <- paste(x$text,as.string(y)$text,sep="")
 404   return(x)
 405 }
 406
 407 print.string <- function(x,...) {
 408   cat(x$text,file=x$file,append=x$append)
 409   return(invisible())
 410 }
 411
 412 string <- function(text,file="",append=FALSE) {
 413   x <- list(text=text,file=file,append=append)
 414   class(x) <- "string"
 415   return(x)
 416 }
 417
 418 as.string <- function(x,file="",append=FALSE) {
 419   if (is.null(attr(x,"class",exact=TRUE)))
 420   switch(data.class(x),
 421       character=return(string(x,file,append)),
 422       numeric=return(string(as.character(x),file,append)),
 423       stop("Cannot coerse argument to a string"))
 424   if (class(x)=="string")
 425     return(x)
 426   stop("Cannot coerse argument to a string")
 427 }
 428
 429 is.string <- function(x) {
 430   return(class(x)=="string")
 431 }
 432