3 ### Produce LaTeX and HTML tables from R objects.
\r
5 ### Copyright 2000-2012 David B. Dahl <dahl@stat.tamu.edu>
\r
7 ### Maintained by Charles Roosen <croosen@mango-solutions.com>
\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
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
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
30 floating.environment="table",
\r
31 table.placement="ht",
\r
32 caption.placement="bottom",
\r
33 latex.environments=c("center"),
\r
34 tabular.environment="tabular",
\r
36 hline.after=c(-1,0,nrow(x)),
\r
38 include.rownames=TRUE,
\r
39 include.colnames=TRUE,
\r
40 only.contents=FALSE,
\r
42 sanitize.text.function=NULL,
\r
43 sanitize.rownames.function=sanitize.text.function,
\r
44 sanitize.colnames.function=sanitize.text.function,
\r
45 math.style.negative=FALSE,
\r
46 html.table.attributes="border=1",
\r
50 rotate.rownames=FALSE,
\r
51 rotate.colnames=FALSE,
\r
53 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after
\r
54 # 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
55 # Old code that set hline.after should include c(-1, 0, nrow(x)) in the hline.after vector
\r
56 # If you do not want any \hline inside the data, set hline.after to NULL
\r
57 # PHEADER instead the string '\\hline\n' is used in the code
\r
58 # Now hline.after counts how many time a position appear
\r
59 # I left an automatic PHEADER in the longtable is this correct?
\r
61 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.rownames, include.colnames
\r
63 if (include.rownames) pos <- 1
\r
65 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after checks
\r
66 if (any(hline.after < -1) | any(hline.after > nrow(x))) stop("'hline.after' must be inside [-1, nrow(x)]")
\r
68 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row checks
\r
69 if (!is.null(add.to.row)) {
\r
70 if (is.list(add.to.row) && length(add.to.row)==2) {
\r
71 if (is.null(names(add.to.row))) {
\r
72 names(add.to.row) <- c('pos', 'command')
\r
73 } else if (any(sort(names(add.to.row))!=c('command', 'pos'))) {
\r
74 stop("the names of the elements of 'add.to.row' must be 'pos' and 'command'")
\r
76 if (is.list(add.to.row$pos) && is.vector(add.to.row$command, mode='character')) {
\r
77 if ((npos <- length(add.to.row$pos)) != length(add.to.row$command)) {
\r
78 stop("the length of 'add.to.row$pos' must be equal to the length of 'add.to.row$command'")
\r
80 if (any(unlist(add.to.row$pos) < -1) | any(unlist(add.to.row$pos) > nrow(x))) {
\r
81 stop("the values in add.to.row$pos must be inside the interval [-1, nrow(x)]")
\r
84 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
87 stop("'add.to.row' argument must be a list of length 2")
\r
90 add.to.row <- list(pos=list(), command=vector(length=0, mode="character"))
\r
94 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row
\r
95 # Add further commands at the end of rows
\r
96 if (type=="latex") {
\r
97 PHEADER <- "\\hline\n"
\r
98 # John Leonard <jleonard99@gmail.com> October 21, 2011
\r
99 # The extra \hline gets in the way when using longtable and add.to.row
\r
100 if(tabular.environment=="longtable" && !is.null(add.to.row) ) {
\r
107 lastcol <- rep(" ", nrow(x)+2)
\r
108 if (!is.null(hline.after)) {
\r
109 add.to.row$pos[[npos+1]] <- hline.after
\r
110 add.to.row$command <- c(add.to.row$command, PHEADER)
\r
112 if ( length(add.to.row$command) > 0 ) {
\r
113 for (i in 1:length(add.to.row$command)) {
\r
114 addpos <- add.to.row$pos[[i]]
\r
115 freq <- table(addpos)
\r
116 addpos <- unique(addpos)
\r
117 for (j in 1:length(addpos)) {
\r
118 lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2], paste(rep(add.to.row$command[i], freq[j]), sep="", collapse=""), sep=" ")
\r
123 if (length(type)>1) stop("\"type\" must have length 1")
\r
124 type <- tolower(type)
\r
125 if (!all(!is.na(match(type,c("latex","html"))))) stop("\"type\" must be in {\"latex\", \"html\"}")
\r
126 if (!all(!is.na(match(floating.environment,c("table","table*","sidewaystable"))))) stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\"}")
\r
127 if (!is.null(table.placement) && !all(!is.na(match(unlist(strsplit(table.placement, split="")),c("H","h","t","b","p","!"))))) {
\r
128 stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")
\r
130 if (!all(!is.na(match(caption.placement,c("bottom","top"))))) stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")
\r
132 if (type=="latex") {
\r
135 # See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003 regarding "texfloat"
\r
136 # See e-mail form "Fernando Henrique Ferraz P. da Rosa" <academic@feferraz.net>" dated 10-28-2005 regarding "longtable"
\r
137 if ( tabular.environment == "longtable" & floating == TRUE ) {
\r
138 warning("Attempt to use \"longtable\" with floating=TRUE. Changing to FALSE.")
\r
141 if ( floating == TRUE ) {
\r
142 # See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>" dated 7-09-2003 regarding "suggestion for an amendment of the source"
\r
143 # See e-mail from "Mitchell, David" <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding "Additions to R xtable package"
\r
144 # See e-mail from "Garbade, Sven" <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22 regarding the floating environment.
\r
145 BTABLE <- paste("\\begin{", floating.environment, "}",ifelse(!is.null(table.placement),
\r
146 paste("[",table.placement,"]",sep=""),""),"\n",sep="")
\r
147 if ( is.null(latex.environments) || (length(latex.environments)==0) ) {
\r
154 for ( i in 1:length(latex.environments) ) {
\r
155 if ( latex.environments[i] == "" ) next
\r
156 BENVIRONMENT <- paste(BENVIRONMENT, "\\begin{",latex.environments[i],"}\n",sep="")
\r
157 EENVIRONMENT <- paste("\\end{",latex.environments[i],"}\n",EENVIRONMENT,sep="")
\r
160 ETABLE <- paste("\\end{", floating.environment, "}\n", sep="")
\r
169 tmp.index.start <- 1
\r
170 if ( ! include.rownames ) {
\r
171 while ( attr(x,"align",exact=TRUE)[tmp.index.start] == '|' ) tmp.index.start <- tmp.index.start + 1
\r
172 tmp.index.start <- tmp.index.start + 1
\r
174 BTABULAR <- paste("\\begin{",tabular.environment,"}{",
\r
175 paste(c(attr(x, "align",exact=TRUE)[tmp.index.start:length(attr(x,"align",exact=TRUE))], "}\n"),
\r
176 sep="", collapse=""),
\r
179 ## fix 10-26-09 (robert.castelo@upf.edu) the following 'if' condition is added here to support
\r
180 ## a caption on the top of a longtable
\r
181 if (tabular.environment == "longtable" && caption.placement=="top") {
\r
182 if (is.null(short.caption)){
\r
183 BCAPTION <- "\\caption{"
\r
185 BCAPTION <- paste("\\caption[", short.caption, "]{", sep="")
\r
187 ECAPTION <- "} \\\\ \n"
\r
188 if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) BTABULAR <- paste(BTABULAR, BCAPTION, attr(x,"caption",exact=TRUE), ECAPTION, sep="")
\r
190 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row position -1
\r
191 BTABULAR <- paste(BTABULAR,lastcol[1], sep="")
\r
192 # the \hline at the end, if present, is set in full matrix
\r
193 ETABULAR <- paste("\\end{",tabular.environment,"}\n",sep="")
\r
195 # BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail dated Wednesday, December 01, 2004
\r
196 if (is.null(size) || !is.character(size)) {
\r
200 if(length(grep("^\\\\",size))==0){
\r
201 size <- paste("\\",size,sep="")
\r
203 BSIZE <- paste("{",size,"\n",sep="")
\r
206 BLABEL <- "\\label{"
\r
208 if (is.null(short.caption)){
\r
209 BCAPTION <- "\\caption{"
\r
211 BCAPTION <- paste("\\caption[", short.caption, "]{", sep="")
\r
223 # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
\r
224 sanitize <- function(str) {
\r
226 result <- gsub("\\\\","SANITIZE.BACKSLASH",result)
\r
227 result <- gsub("$","\\$",result,fixed=TRUE)
\r
228 result <- gsub(">","$>$",result,fixed=TRUE)
\r
229 result <- gsub("<","$<$",result,fixed=TRUE)
\r
230 result <- gsub("|","$|$",result,fixed=TRUE)
\r
231 result <- gsub("{","\\{",result,fixed=TRUE)
\r
232 result <- gsub("}","\\}",result,fixed=TRUE)
\r
233 result <- gsub("%","\\%",result,fixed=TRUE)
\r
234 result <- gsub("&","\\&",result,fixed=TRUE)
\r
235 result <- gsub("_","\\_",result,fixed=TRUE)
\r
236 result <- gsub("#","\\#",result,fixed=TRUE)
\r
237 result <- gsub("^","\\verb|^|",result,fixed=TRUE)
\r
238 result <- gsub("~","\\~{}",result,fixed=TRUE)
\r
239 result <- gsub("SANITIZE.BACKSLASH","$\\backslash$",result,fixed=TRUE)
\r
242 sanitize.numbers <- function(x) {
\r
244 if ( math.style.negative ) {
\r
245 # Jake Bowers <jwbowers@illinois.edu> in e-mail from 2008-08-20 suggested
\r
246 # disabling this feature to avoid problems with LaTeX's dcolumn package.
\r
247 # by Florian Wickelmaier <florian.wickelmaier@uni-tuebingen.de> in e-mail
\r
248 # from 2008-10-03 requested the ability to use the old behavior.
\r
249 for(i in 1:length(x)) {
\r
250 result[i] <- gsub("-","$-$",result[i],fixed=TRUE)
\r
255 sanitize.final <- function(result) {
\r
259 BCOMMENT <- "<!-- "
\r
260 ECOMMENT <- " -->\n"
\r
261 BTABLE <- paste("<TABLE ",html.table.attributes,">\n",sep="")
\r
262 ETABLE <- "</TABLE>\n"
\r
269 BLABEL <- "<A NAME="
\r
270 ELABEL <- "></A>\n"
\r
271 BCAPTION <- paste("<CAPTION ALIGN=\"",caption.placement,"\"> ",sep="")
\r
272 ECAPTION <- " </CAPTION>\n"
\r
277 STH <- " </TH> <TH> "
\r
278 BTD1 <- " <TD align=\""
\r
279 align.tmp <- attr(x,"align",exact=TRUE)
\r
280 align.tmp <- align.tmp[align.tmp!="|"]
\r
281 BTD2 <- matrix(align.tmp[(2-pos):(ncol(x)+1)],nrow=nrow(x),ncol=ncol(x)+pos,byrow=TRUE)
\r
282 # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
\r
283 BTD2[regexpr("^p",BTD2)>0] <- "left"
\r
284 BTD2[BTD2=="r"] <- "right"
\r
285 BTD2[BTD2=="l"] <- "left"
\r
286 BTD2[BTD2=="c"] <- "center"
\r
289 sanitize <- function(str) {
\r
291 result <- gsub("&","& ",result,fixed=TRUE)
\r
292 result <- gsub(">","> ",result,fixed=TRUE)
\r
293 result <- gsub("<","< ",result,fixed=TRUE)
\r
294 # Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05 recommended not escaping underscores.
\r
295 # result <- gsub("_", "\\_", result, fixed=TRUE)
\r
298 sanitize.numbers <- function(x) {
\r
301 sanitize.final <- function(result) {
\r
302 # Suggested by Uwe Ligges <ligges@statistik.uni-dortmund.de> in e-mail dated 2005-07-30.
\r
303 result$text <- gsub(" *"," ", result$text,fixed=TRUE)
\r
304 result$text <- gsub(' align="left"', "", result$text,fixed=TRUE)
\r
309 result <- string("",file=file,append=append)
\r
310 info <- R.Version()
\r
311 # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 to set automatically the package version
\r
312 result <- result + BCOMMENT + type + " table generated in " +
\r
313 info$language + " " + info$major + "." + info$minor + " by xtable " + packageDescription('xtable')$Version + " package" + ECOMMENT
\r
314 result <- result + BCOMMENT + date() + ECOMMENT
\r
315 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents
\r
316 if (!only.contents) {
\r
317 result <- result + BTABLE
\r
318 result <- result + BENVIRONMENT
\r
319 if ( floating == TRUE ) {
\r
320 if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="html" || caption.placement=="top")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
\r
321 if (!is.null(attr(x,"label",exact=TRUE)) && (type=="latex" && caption.placement=="top")) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
\r
323 result <- result + BSIZE
\r
324 result <- result + BTABULAR
\r
326 # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.colnames, include.rownames
\r
327 if (include.colnames) {
\r
328 result <- result + BROW + BTH
\r
329 if (include.rownames) {
\r
330 result <- result + STH
\r
332 # David G. Whiting in e-mail 2007-10-09
\r
333 if (is.null(sanitize.colnames.function)) {
\r
334 CNAMES <- sanitize(names(x))
\r
336 CNAMES <- sanitize.colnames.function(names(x))
\r
338 if (rotate.colnames) {
\r
339 #added by Markus Loecher, 2009-11-16
\r
340 CNAMES <- paste("\\begin{sideways}", CNAMES, "\\end{sideways}")
\r
342 result <- result + paste(CNAMES, collapse=STH)
\r
344 result <- result + ETH + EROW
\r
347 cols <- matrix("",nrow=nrow(x),ncol=ncol(x)+pos)
\r
348 if (include.rownames) {
\r
349 # David G. Whiting in e-mail 2007-10-09
\r
350 if (is.null(sanitize.rownames.function)) {
\r
351 RNAMES <- sanitize(row.names(x))
\r
353 RNAMES <- sanitize.rownames.function(row.names(x))
\r
355 if (rotate.rownames) {
\r
356 #added by Markus Loecher, 2009-11-16
\r
357 RNAMES <- paste("\\begin{sideways}", RNAMES, "\\end{sideways}")
\r
362 ## Begin vectorizing the formatting code by Ian Fellows [ian@fellstat.com]
\r
365 # disp <- function(y) {
\r
366 # if (is.factor(y)) {
\r
367 # y <- levels(y)[y]
\r
369 # if (is.list(y)) {
\r
374 varying.digits <- is.matrix( attr( x, "digits",exact=TRUE ) )
\r
375 # 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
376 #if( !varying.digits ) {
\r
377 # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28
\r
378 # attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ), nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )
\r
380 for(i in 1:ncol(x)) {
\r
382 if(is.factor(xcol))
\r
383 xcol <- as.character(xcol)
\r
385 xcol <- sapply(xcol,unlist)
\r
387 is.numeric.column <- is.numeric(xcol)
\r
389 if(is.character(xcol)) {
\r
390 cols[,i+pos] <- xcol
\r
392 if (is.null(format.args)){
\r
393 format.args <- list()
\r
395 if (is.null(format.args$decimal.mark)){
\r
396 format.args$decimal.mark <- options()$OutDec
\r
398 if(!varying.digits){
\r
399 curFormatArgs <- c(list(
\r
401 format = ifelse( attr( x, "digits",exact=TRUE )[i+1] < 0, "E",
\r
402 attr( x, "display",exact=TRUE )[i+1] ),
\r
403 digits = abs( attr( x, "digits",exact=TRUE )[i+1] )),
\r
405 cols[,i+pos] <- do.call("formatC", curFormatArgs)
\r
407 for( j in 1:nrow( cols ) ) {
\r
408 curFormatArgs <- c(list(
\r
410 format = ifelse( attr( x, "digits",exact=TRUE )[j,i+1] < 0, "E",
\r
411 attr( x, "display",exact=TRUE )[i+1] ),
\r
412 digits = abs( attr( x, "digits",exact=TRUE )[j,i+1] )),
\r
414 cols[j,i+pos] <- do.call("formatC", curFormatArgs)
\r
418 ## End Ian Fellows changes
\r
420 if ( any(ina) ) cols[ina,i+pos] <- NA.string
\r
421 # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
\r
422 if ( is.numeric.column ) {
\r
423 cols[,i+pos] <- sanitize.numbers(cols[,i+pos])
\r
425 if (is.null(sanitize.text.function)) {
\r
426 cols[,i+pos] <- sanitize(cols[,i+pos])
\r
428 cols[,i+pos] <- sanitize.text.function(cols[,i+pos])
\r
434 full <- matrix("",nrow=nrow(x),ncol=multiplier*(ncol(x)+pos)+2)
\r
436 full[,multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1
\r
437 full[,multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2
\r
438 full[,multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3
\r
439 full[,multiplier*(0:(ncol(x)+pos-1))+5] <- cols
\r
440 full[,multiplier*(0:(ncol(x)+pos-1))+6] <- ETD
\r
442 full[,multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)], sep=" ")
\r
444 # John Leonard <jleonard99@gmail.com> October 21, 2011
\r
445 # Removes the "\\" from the last row of the contents so that
\r
446 # booktabs (\bottomline) appears in the correct position.
\r
447 if(tabular.environment=="longtable" & !is.null(add.to.row)) {
\r
448 full[dim(full)[1],multiplier*(ncol(x)+pos)+2] <- "%\n"
\r
451 if (type=="latex") full[,2] <- ""
\r
452 result <- result + lastcol[2] + paste(t(full),collapse="")
\r
453 if (!only.contents) {
\r
454 if (tabular.environment == "longtable") {
\r
455 result <- result + PHEADER
\r
456 ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the following 'if' condition is inserted in order to avoid
\r
457 ## that bottom caption interferes with a top caption of a longtable
\r
458 if(caption.placement=="bottom"){
\r
459 if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
\r
461 if (!is.null(attr(x,"label",exact=TRUE))) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
\r
462 ETABULAR <- "\\end{longtable}\n"
\r
464 result <- result + ETABULAR
\r
465 result <- result + ESIZE
\r
466 if ( floating == TRUE ) {
\r
467 if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex" && caption.placement=="bottom")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
\r
468 if (!is.null(attr(x,"label",exact=TRUE)) && caption.placement=="bottom") result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
\r
470 result <- result + EENVIRONMENT
\r
471 result <- result + ETABLE
\r
473 result <- sanitize.final(result)
\r
474 if (print.results){
\r
478 return(invisible(result$text))
\r
481 "+.string" <- function(x,y) {
\r
482 x$text <- paste(x$text,as.string(y)$text,sep="")
\r
486 print.string <- function(x,...) {
\r
487 cat(x$text,file=x$file,append=x$append)
\r
488 return(invisible())
\r
491 string <- function(text,file="",append=FALSE) {
\r
492 x <- list(text=text,file=file,append=append)
\r
493 class(x) <- "string"
\r
497 as.string <- function(x,file="",append=FALSE) {
\r
498 if (is.null(attr(x,"class",exact=TRUE)))
\r
499 switch(data.class(x),
\r
500 character=return(string(x,file,append)),
\r
501 numeric=return(string(as.character(x),file,append)),
\r
502 stop("Cannot coerse argument to a string"))
\r
503 if (class(x)=="string")
\r
505 stop("Cannot coerse argument to a string")
\r
508 is.string <- function(x) {
\r
509 return(class(x)=="string")
\r