-### xtable package
-###
-### Produce LaTeX and HTML tables from R objects.
-###
-### Copyright 2000-2007 David B. Dahl <dahl@stat.tamu.edu>
-###
-### This file is part of the `xtable' library for R and related languages.
-### It is made available under the terms of the GNU General Public
-### License, version 2, or at your option, any later version,
-### incorporated herein by reference.
-###
-### This program is distributed in the hope that it will be
-### useful, but WITHOUT ANY WARRANTY; without even the implied
-### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-### PURPOSE. See the GNU General Public License for more
-### details.
-###
-### You should have received a copy of the GNU General Public
-### License along with this program; if not, write to the Free
-### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
-### MA 02111-1307, USA
-print.xtable <- function(
- x,
- type="latex",
- file="",
- append=FALSE,
- floating=TRUE,
- floating.environment="table",
- table.placement="ht",
- caption.placement="bottom",
- latex.environments=c("center"),
- tabular.environment="tabular",
- size=NULL,
- hline.after=c(-1,0,nrow(x)),
- NA.string="",
- include.rownames=TRUE,
- include.colnames=TRUE,
- only.contents=FALSE,
- add.to.row=NULL,
- sanitize.text.function=NULL,
- sanitize.rownames.function=sanitize.text.function,
- sanitize.colnames.function=sanitize.text.function,
- math.style.negative=FALSE,
- html.table.attributes="border=1",
- ...) {
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after
- # 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
- # Old code that set hline.after should include c(-1, 0, nrow(x)) in the hline.after vector
- # If you do not want any \hline inside the data, set hline.after to NULL
- # PHEADER instead the string '\\hline\n' is used in the code
- # Now hline.after counts how many time a position appear
- # I left an automatic PHEADER in the longtable is this correct?
-
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.rownames, include.colnames
- pos <- 0
- if (include.rownames) pos <- 1
-
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after checks
- if (any(hline.after < -1) | any(hline.after > nrow(x))) stop("'hline.after' must be inside [-1, nrow(x)]")
-
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row checks
- if (!is.null(add.to.row)) {
- if (is.list(add.to.row) && length(add.to.row)==2) {
- if (is.null(names(add.to.row))) {
- names(add.to.row) <- c('pos', 'command')
- } else if (any(sort(names(add.to.row))!=c('command', 'pos'))) {
- stop("the names of the elements of 'add.to.row' must be 'pos' and 'command'")
- }
- if (is.list(add.to.row$pos) && is.vector(add.to.row$command, mode='character')) {
- if ((npos <- length(add.to.row$pos)) != length(add.to.row$command)) {
- stop("the length of 'add.to.row$pos' must be equal to the length of 'add.to.row$command'")
- }
- if (any(unlist(add.to.row$pos) < -1) | any(unlist(add.to.row$pos) > nrow(x))) {
- stop("the values in add.to.row$pos must be inside the interval [-1, nrow(x)]")
- }
- } else {
- stop("the first argument ('pos') of 'add.to.row' must be a list, the second argument ('command') must be a vector of mode character")
- }
- } else {
- stop("'add.to.row' argument must be a list of length 2")
- }
- } else {
- add.to.row <- list(pos=list(), command=vector(length=0, mode="character"))
- npos <- 0
- }
-
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row
- # Add further commands at the end of rows
- if (type=="latex") {
- PHEADER <- "\\hline\n"
- } else {
- PHEADER <- ""
- }
-
- lastcol <- rep(" ", nrow(x)+2)
- if (!is.null(hline.after)) {
- add.to.row$pos[[npos+1]] <- hline.after
- add.to.row$command <- c(add.to.row$command, PHEADER)
- }
- if ( length(add.to.row$command) > 0 ) {
- for (i in 1:length(add.to.row$command)) {
- addpos <- add.to.row$pos[[i]]
- freq <- table(addpos)
- addpos <- unique(addpos)
- for (j in 1:length(addpos)) {
- lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2], paste(rep(add.to.row$command[i], freq[j]), sep="", collapse=""), sep=" ")
- }
- }
- }
-
- if (length(type)>1) stop("\"type\" must have length 1")
- type <- tolower(type)
- if (!all(!is.na(match(type,c("latex","html"))))) stop("\"type\" must be in {\"latex\", \"html\"}")
- if (!all(!is.na(match(floating.environment,c("table","table*","sidewaystable"))))) stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\"}")
- if (!all(!is.na(match(unlist(strsplit(table.placement, split="")),c("H","h","t","b","p","!"))))) {
- stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")
- }
- if (!all(!is.na(match(caption.placement,c("bottom","top"))))) stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")
-
- if (type=="latex") {
- BCOMMENT <- "% "
- ECOMMENT <- "\n"
- # See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003 regarding "texfloat"
- # See e-mail form "Fernando Henrique Ferraz P. da Rosa" <academic@feferraz.net>" dated 10-28-2005 regarding "longtable"
- if ( tabular.environment == "longtable" & floating == TRUE ) {
- warning("Attempt to use \"longtable\" with floating=TRUE. Changing to FALSE.")
- floating <- FALSE
- }
- if ( floating == TRUE ) {
- # See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>" dated 7-09-2003 regarding "suggestion for an amendment of the source"
- # See e-mail from "Mitchell, David" <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding "Additions to R xtable package"
- # See e-mail from "Garbade, Sven" <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22 regarding the floating environment.
- BTABLE <- paste("\\begin{", floating.environment, "}",ifelse(!is.null(table.placement),
- paste("[",table.placement,"]",sep=""),""),"\n",sep="")
- if ( is.null(latex.environments) || (length(latex.environments)==0) ) {
- BENVIRONMENT <- ""
- EENVIRONMENT <- ""
- }
- else {
- BENVIRONMENT <- ""
- EENVIRONMENT <- ""
- for ( i in 1:length(latex.environments) ) {
- if ( latex.environments[i] == "" ) next
- BENVIRONMENT <- paste(BENVIRONMENT, "\\begin{",latex.environments[i],"}\n",sep="")
- EENVIRONMENT <- paste("\\end{",latex.environments[i],"}\n",EENVIRONMENT,sep="")
- }
- }
- ETABLE <- paste("\\end{", floating.environment, "}\n", sep="")
- }
- else {
- BTABLE <- ""
- ETABLE <- ""
- BENVIRONMENT <- ""
- EENVIRONMENT <- ""
- }
-
- tmp.index.start <- 1
- if ( ! include.rownames ) {
- while ( attr(x,"align",exact=TRUE)[tmp.index.start] == '|' ) tmp.index.start <- tmp.index.start + 1
- tmp.index.start <- tmp.index.start + 1
- }
- BTABULAR <- paste("\\begin{",tabular.environment,"}{",
- paste(c(attr(x, "align",exact=TRUE)[tmp.index.start:length(attr(x,"align",exact=TRUE))], "}\n"),
- sep="", collapse=""),
- sep="")
-
- ## fix 10-26-09 (robert.castelo@upf.edu) the following 'if' condition is added here to support
- ## a caption on the top of a longtable
- if (tabular.environment == "longtable" && caption.placement=="top") {
- BCAPTION <- "\\caption{"
- ECAPTION <- "} \\\\ \n"
- if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) BTABULAR <- paste(BTABULAR, BCAPTION, attr(x,"caption",exact=TRUE), ECAPTION, sep="")
- }
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row position -1
- BTABULAR <- paste(BTABULAR,lastcol[1], sep="")
- # the \hline at the end, if present, is set in full matrix
- ETABULAR <- paste("\\end{",tabular.environment,"}\n",sep="")
-
- # BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail dated Wednesday, December 01, 2004
- if (is.null(size) || !is.character(size)) {
- BSIZE <- ""
- ESIZE <- ""
- } else {
- if(length(grep("^\\\\",size))==0){
- size <- paste("\\",size,sep="")
- }
- BSIZE <- paste("{",size,"\n",sep="")
- ESIZE <- "}\n"
- }
- BLABEL <- "\\label{"
- ELABEL <- "}\n"
- BCAPTION <- "\\caption{"
- ECAPTION <- "}\n"
- BROW <- ""
- EROW <- " \\\\ \n"
- BTH <- ""
- ETH <- ""
- STH <- " & "
- BTD1 <- " & "
- BTD2 <- ""
- BTD3 <- ""
- ETD <- ""
- # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
- sanitize <- function(str) {
- result <- str
- result <- gsub("\\\\","SANITIZE.BACKSLASH",result)
- result <- gsub("$","\\$",result,fixed=TRUE)
- result <- gsub(">","$>$",result,fixed=TRUE)
- result <- gsub("<","$<$",result,fixed=TRUE)
- result <- gsub("|","$|$",result,fixed=TRUE)
- result <- gsub("{","\\{",result,fixed=TRUE)
- result <- gsub("}","\\}",result,fixed=TRUE)
- result <- gsub("%","\\%",result,fixed=TRUE)
- result <- gsub("&","\\&",result,fixed=TRUE)
- result <- gsub("_","\\_",result,fixed=TRUE)
- result <- gsub("#","\\#",result,fixed=TRUE)
- result <- gsub("^","\\verb|^|",result,fixed=TRUE)
- result <- gsub("~","\\~{}",result,fixed=TRUE)
- result <- gsub("SANITIZE.BACKSLASH","$\\backslash$",result,fixed=TRUE)
- return(result)
- }
- sanitize.numbers <- function(x) {
- result <- x
- if ( math.style.negative ) {
- # Jake Bowers <jwbowers@illinois.edu> in e-mail from 2008-08-20 suggested
- # disabling this feature to avoid problems with LaTeX's dcolumn package.
- # by Florian Wickelmaier <florian.wickelmaier@uni-tuebingen.de> in e-mail
- # from 2008-10-03 requested the ability to use the old behavior.
- for(i in 1:length(x)) {
- result[i] <- gsub("-","$-$",result[i],fixed=TRUE)
- }
- }
- return(result)
- }
- sanitize.final <- function(result) {
- return(result)
- }
- } else {
- BCOMMENT <- "<!-- "
- ECOMMENT <- " -->\n"
- BTABLE <- paste("<TABLE ",html.table.attributes,">\n",sep="")
- ETABLE <- "</TABLE>\n"
- BENVIRONMENT <- ""
- EENVIRONMENT <- ""
- BTABULAR <- ""
- ETABULAR <- ""
- BSIZE <- ""
- ESIZE <- ""
- BLABEL <- "<A NAME="
- ELABEL <- "></A>\n"
- BCAPTION <- paste("<CAPTION ALIGN=\"",caption.placement,"\"> ",sep="")
- ECAPTION <- " </CAPTION>\n"
- BROW <- "<TR>"
- EROW <- " </TR>\n"
- BTH <- " <TH> "
- ETH <- " </TH> "
- STH <- " </TH> <TH> "
- BTD1 <- " <TD align=\""
- align.tmp <- attr(x,"align",exact=TRUE)
- align.tmp <- align.tmp[align.tmp!="|"]
- BTD2 <- matrix(align.tmp[(2-pos):(ncol(x)+1)],nrow=nrow(x),ncol=ncol(x)+pos,byrow=TRUE)
- # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
- BTD2[regexpr("^p",BTD2)>0] <- "left"
- BTD2[BTD2=="r"] <- "right"
- BTD2[BTD2=="l"] <- "left"
- BTD2[BTD2=="c"] <- "center"
- BTD3 <- "\"> "
- ETD <- " </TD>"
- sanitize <- function(str) {
- result <- str
- result <- gsub("&","& ",result,fixed=TRUE)
- result <- gsub(">","> ",result,fixed=TRUE)
- result <- gsub("<","< ",result,fixed=TRUE)
- # Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05 recommended not escaping underscores.
- # result <- gsub("_", "\\_", result, fixed=TRUE)
- return(result)
- }
- sanitize.numbers <- function(x) {
- return(x)
- }
- sanitize.final <- function(result) {
- # Suggested by Uwe Ligges <ligges@statistik.uni-dortmund.de> in e-mail dated 2005-07-30.
- result$text <- gsub(" *"," ", result$text,fixed=TRUE)
- result$text <- gsub(' align="left"', "", result$text,fixed=TRUE)
- return(result)
- }
- }
-
- result <- string("",file=file,append=append)
- info <- R.Version()
- # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 to set automatically the package version
- result <- result + BCOMMENT + type + " table generated in " +
- info$language + " " + info$major + "." + info$minor + " by xtable " + packageDescription('xtable')$Version + " package" + ECOMMENT
- result <- result + BCOMMENT + date() + ECOMMENT
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents
- if (!only.contents) {
- result <- result + BTABLE
- result <- result + BENVIRONMENT
- if ( floating == TRUE ) {
- if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="html" || caption.placement=="top")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
- if (!is.null(attr(x,"label",exact=TRUE)) && (type=="latex" && caption.placement=="top")) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
- }
- result <- result + BSIZE
- result <- result + BTABULAR
- }
- # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.colnames, include.rownames
- if (include.colnames) {
- result <- result + BROW + BTH
- if (include.rownames) result <- result + STH
- if (is.null(sanitize.colnames.function)) { # David G. Whiting in e-mail 2007-10-09
- result <- result + paste(sanitize(names(x)),collapse=STH)
- } else {
- result <- result + paste(sanitize.colnames.function(names(x)), collapse=STH) # David G. Whiting in e-mail 2007-10-09
- }
- result <- result + ETH + EROW
- }
-
- cols <- matrix("",nrow=nrow(x),ncol=ncol(x)+pos)
- if (include.rownames) {
- if (is.null(sanitize.rownames.function)) { # David G. Whiting in e-mail 2007-10-09
- cols[,1] <- sanitize(row.names(x))
- } else {
- cols[,1] <- sanitize.rownames.function(row.names(x)) # David G. Whiting in e-mail 2007-10-09
- }
- }
-
- disp <- function(y) {
- if (is.factor(y)) {
- y <- levels(y)[y]
- }
- if (is.list(y)) {
- y <- unlist(y)
- }
- return(y)
- }
- # 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.
- if( !is.matrix( attr( x, "digits",exact=TRUE ) ) ) {
- # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28
- attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ), nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )
- }
- for(i in 1:ncol(x)) {
- ina <- is.na(x[,i])
- is.numeric.column <- is.numeric(x[,i])
- for( j in 1:nrow( cols ) ) {
- ### modified Claudio Agostinelli <claudio@unive.it> dated 2009-09-14
- ### add decimal.mark=options()$OutDec
- cols[j,i+pos] <-
- formatC( disp( x[j,i] ),
- 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)
- }
- if ( any(ina) ) cols[ina,i+pos] <- NA.string
- # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
- if ( is.numeric.column ) {
- cols[,i+pos] <- sanitize.numbers(cols[,i+pos])
- } else {
- if (is.null(sanitize.text.function)) {
- cols[,i+pos] <- sanitize(cols[,i+pos])
- } else {
- cols[,i+pos] <- sanitize.text.function(cols[,i+pos])
- }
- }
- }
-
- multiplier <- 5
- full <- matrix("",nrow=nrow(x),ncol=multiplier*(ncol(x)+pos)+2)
- full[,1] <- BROW
- full[,multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1
- full[,multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2
- full[,multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3
- full[,multiplier*(0:(ncol(x)+pos-1))+5] <- cols
- full[,multiplier*(0:(ncol(x)+pos-1))+6] <- ETD
-
- full[,multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)], sep=" ")
- if (type=="latex") full[,2] <- ""
- result <- result + lastcol[2] + paste(t(full),collapse="")
- if (!only.contents) {
- if (tabular.environment == "longtable") {
- result <- result + PHEADER
- ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the following 'if' condition is inserted in order to avoid
- ## that bottom caption interferes with a top caption of a longtable
- if(caption.placement=="bottom"){
- if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
- }
- if (!is.null(attr(x,"label",exact=TRUE))) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
- ETABULAR <- "\\end{longtable}\n"
- }
- result <- result + ETABULAR
- result <- result + ESIZE
- if ( floating == TRUE ) {
- if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex" && caption.placement=="bottom")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION
- if (!is.null(attr(x,"label",exact=TRUE)) && caption.placement=="bottom") result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL
- }
- result <- result + EENVIRONMENT
- result <- result + ETABLE
- }
- result <- sanitize.final(result)
- print(result)
-
- return(invisible(result$text))
-}
-
-"+.string" <- function(x,y) {
- x$text <- paste(x$text,as.string(y)$text,sep="")
- return(x)
-}
-
-print.string <- function(x,...) {
- cat(x$text,file=x$file,append=x$append)
- return(invisible())
-}
-
-string <- function(text,file="",append=FALSE) {
- x <- list(text=text,file=file,append=append)
- class(x) <- "string"
- return(x)
-}
-
-as.string <- function(x,file="",append=FALSE) {
- if (is.null(attr(x,"class",exact=TRUE)))
- switch(data.class(x),
- character=return(string(x,file,append)),
- numeric=return(string(as.character(x),file,append)),
- stop("Cannot coerse argument to a string"))
- if (class(x)=="string")
- return(x)
- stop("Cannot coerse argument to a string")
-}
-
-is.string <- function(x) {
- return(class(x)=="string")
-}
-
+### xtable package\r
+###\r
+### Produce LaTeX and HTML tables from R objects.\r
+###\r
+### Copyright 2000-2012 David B. Dahl <dahl@stat.tamu.edu>\r
+###\r
+### Maintained by Charles Roosen <croosen@mango-solutions.com>\r
+###\r
+### This file is part of the `xtable' library for R and related languages.\r
+### It is made available under the terms of the GNU General Public\r
+### License, version 2, or at your option, any later version,\r
+### incorporated herein by reference.\r
+###\r
+### This program is distributed in the hope that it will be\r
+### useful, but WITHOUT ANY WARRANTY; without even the implied\r
+### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
+### PURPOSE. See the GNU General Public License for more\r
+### details.\r
+###\r
+### You should have received a copy of the GNU General Public\r
+### License along with this program; if not, write to the Free\r
+### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,\r
+### MA 02111-1307, USA\r
+print.xtable <- function(\r
+ x,\r
+ type="latex",\r
+ file="",\r
+ append=FALSE,\r
+ floating=TRUE,\r
+ floating.environment="table",\r
+ table.placement="ht",\r
+ caption.placement="bottom",\r
+ latex.environments=c("center"),\r
+ tabular.environment="tabular",\r
+ size=NULL,\r
+ hline.after=c(-1,0,nrow(x)),\r
+ NA.string="",\r
+ include.rownames=TRUE,\r
+ include.colnames=TRUE,\r
+ only.contents=FALSE,\r
+ add.to.row=NULL,\r
+ sanitize.text.function=NULL,\r
+ sanitize.rownames.function=sanitize.text.function,\r
+ sanitize.colnames.function=sanitize.text.function,\r
+ math.style.negative=FALSE,\r
+ html.table.attributes="border=1",\r
+ ...) {\r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after\r
+ # 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
+ # Old code that set hline.after should include c(-1, 0, nrow(x)) in the hline.after vector\r
+ # If you do not want any \hline inside the data, set hline.after to NULL \r
+ # PHEADER instead the string '\\hline\n' is used in the code\r
+ # Now hline.after counts how many time a position appear \r
+ # I left an automatic PHEADER in the longtable is this correct?\r
+\r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.rownames, include.colnames \r
+ pos <- 0\r
+ if (include.rownames) pos <- 1\r
+ \r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 hline.after checks\r
+ if (any(hline.after < -1) | any(hline.after > nrow(x))) stop("'hline.after' must be inside [-1, nrow(x)]")\r
+ \r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row checks\r
+ if (!is.null(add.to.row)) {\r
+ if (is.list(add.to.row) && length(add.to.row)==2) {\r
+ if (is.null(names(add.to.row))) {\r
+ names(add.to.row) <- c('pos', 'command')\r
+ } else if (any(sort(names(add.to.row))!=c('command', 'pos'))) {\r
+ stop("the names of the elements of 'add.to.row' must be 'pos' and 'command'")\r
+ }\r
+ if (is.list(add.to.row$pos) && is.vector(add.to.row$command, mode='character')) {\r
+ if ((npos <- length(add.to.row$pos)) != length(add.to.row$command)) {\r
+ stop("the length of 'add.to.row$pos' must be equal to the length of 'add.to.row$command'")\r
+ }\r
+ if (any(unlist(add.to.row$pos) < -1) | any(unlist(add.to.row$pos) > nrow(x))) {\r
+ stop("the values in add.to.row$pos must be inside the interval [-1, nrow(x)]")\r
+ }\r
+ } else {\r
+ 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
+ }\r
+ } else {\r
+ stop("'add.to.row' argument must be a list of length 2")\r
+ }\r
+ } else {\r
+ add.to.row <- list(pos=list(), command=vector(length=0, mode="character"))\r
+ npos <- 0\r
+ }\r
+\r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row\r
+ # Add further commands at the end of rows\r
+ if (type=="latex") {\r
+ PHEADER <- "\\hline\n"\r
+ } else {\r
+ PHEADER <- ""\r
+ }\r
+ \r
+ lastcol <- rep(" ", nrow(x)+2)\r
+ if (!is.null(hline.after)) {\r
+ add.to.row$pos[[npos+1]] <- hline.after\r
+ add.to.row$command <- c(add.to.row$command, PHEADER)\r
+ }\r
+ if ( length(add.to.row$command) > 0 ) {\r
+ for (i in 1:length(add.to.row$command)) {\r
+ addpos <- add.to.row$pos[[i]]\r
+ freq <- table(addpos)\r
+ addpos <- unique(addpos)\r
+ for (j in 1:length(addpos)) {\r
+ lastcol[addpos[j]+2] <- paste(lastcol[addpos[j]+2], paste(rep(add.to.row$command[i], freq[j]), sep="", collapse=""), sep=" ")\r
+ }\r
+ }\r
+ }\r
+ \r
+ if (length(type)>1) stop("\"type\" must have length 1")\r
+ type <- tolower(type)\r
+ if (!all(!is.na(match(type,c("latex","html"))))) stop("\"type\" must be in {\"latex\", \"html\"}")\r
+ if (!all(!is.na(match(floating.environment,c("table","table*","sidewaystable"))))) stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\"}")\r
+ if (!all(!is.na(match(unlist(strsplit(table.placement, split="")),c("H","h","t","b","p","!"))))) {\r
+ stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")\r
+ }\r
+ if (!all(!is.na(match(caption.placement,c("bottom","top"))))) stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")\r
+\r
+ if (type=="latex") {\r
+ BCOMMENT <- "% "\r
+ ECOMMENT <- "\n"\r
+ # See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003 regarding "texfloat"\r
+ # See e-mail form "Fernando Henrique Ferraz P. da Rosa" <academic@feferraz.net>" dated 10-28-2005 regarding "longtable"\r
+ if ( tabular.environment == "longtable" & floating == TRUE ) {\r
+ warning("Attempt to use \"longtable\" with floating=TRUE. Changing to FALSE.")\r
+ floating <- FALSE\r
+ }\r
+ if ( floating == TRUE ) {\r
+ # See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>" dated 7-09-2003 regarding "suggestion for an amendment of the source"\r
+ # See e-mail from "Mitchell, David" <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding "Additions to R xtable package"\r
+ # See e-mail from "Garbade, Sven" <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22 regarding the floating environment.\r
+ BTABLE <- paste("\\begin{", floating.environment, "}",ifelse(!is.null(table.placement),\r
+ paste("[",table.placement,"]",sep=""),""),"\n",sep="")\r
+ if ( is.null(latex.environments) || (length(latex.environments)==0) ) {\r
+ BENVIRONMENT <- ""\r
+ EENVIRONMENT <- ""\r
+ }\r
+ else {\r
+ BENVIRONMENT <- ""\r
+ EENVIRONMENT <- ""\r
+ for ( i in 1:length(latex.environments) ) {\r
+ if ( latex.environments[i] == "" ) next\r
+ BENVIRONMENT <- paste(BENVIRONMENT, "\\begin{",latex.environments[i],"}\n",sep="")\r
+ EENVIRONMENT <- paste("\\end{",latex.environments[i],"}\n",EENVIRONMENT,sep="")\r
+ }\r
+ }\r
+ ETABLE <- paste("\\end{", floating.environment, "}\n", sep="")\r
+ }\r
+ else {\r
+ BTABLE <- ""\r
+ ETABLE <- ""\r
+ BENVIRONMENT <- ""\r
+ EENVIRONMENT <- ""\r
+ }\r
+\r
+ tmp.index.start <- 1\r
+ if ( ! include.rownames ) {\r
+ while ( attr(x,"align",exact=TRUE)[tmp.index.start] == '|' ) tmp.index.start <- tmp.index.start + 1\r
+ tmp.index.start <- tmp.index.start + 1\r
+ }\r
+ BTABULAR <- paste("\\begin{",tabular.environment,"}{",\r
+ paste(c(attr(x, "align",exact=TRUE)[tmp.index.start:length(attr(x,"align",exact=TRUE))], "}\n"),\r
+ sep="", collapse=""),\r
+ sep="")\r
+ \r
+ ## fix 10-26-09 (robert.castelo@upf.edu) the following 'if' condition is added here to support\r
+ ## a caption on the top of a longtable\r
+ if (tabular.environment == "longtable" && caption.placement=="top") {\r
+ BCAPTION <- "\\caption{"\r
+ ECAPTION <- "} \\\\ \n"\r
+ if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) BTABULAR <- paste(BTABULAR, BCAPTION, attr(x,"caption",exact=TRUE), ECAPTION, sep="")\r
+ }\r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 add.to.row position -1\r
+ BTABULAR <- paste(BTABULAR,lastcol[1], sep="")\r
+ # the \hline at the end, if present, is set in full matrix \r
+ ETABULAR <- paste("\\end{",tabular.environment,"}\n",sep="")\r
+ \r
+ # BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail dated Wednesday, December 01, 2004\r
+ if (is.null(size) || !is.character(size)) {\r
+ BSIZE <- ""\r
+ ESIZE <- ""\r
+ } else {\r
+ if(length(grep("^\\\\",size))==0){\r
+ size <- paste("\\",size,sep="")\r
+ }\r
+ BSIZE <- paste("{",size,"\n",sep="")\r
+ ESIZE <- "}\n"\r
+ }\r
+ BLABEL <- "\\label{"\r
+ ELABEL <- "}\n"\r
+ BCAPTION <- "\\caption{"\r
+ ECAPTION <- "}\n"\r
+ BROW <- ""\r
+ EROW <- " \\\\ \n"\r
+ BTH <- ""\r
+ ETH <- ""\r
+ STH <- " & "\r
+ BTD1 <- " & "\r
+ BTD2 <- ""\r
+ BTD3 <- ""\r
+ ETD <- ""\r
+ # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007\r
+ sanitize <- function(str) {\r
+ result <- str\r
+ result <- gsub("\\\\","SANITIZE.BACKSLASH",result)\r
+ result <- gsub("$","\\$",result,fixed=TRUE)\r
+ result <- gsub(">","$>$",result,fixed=TRUE)\r
+ result <- gsub("<","$<$",result,fixed=TRUE)\r
+ result <- gsub("|","$|$",result,fixed=TRUE)\r
+ result <- gsub("{","\\{",result,fixed=TRUE)\r
+ result <- gsub("}","\\}",result,fixed=TRUE)\r
+ result <- gsub("%","\\%",result,fixed=TRUE)\r
+ result <- gsub("&","\\&",result,fixed=TRUE)\r
+ result <- gsub("_","\\_",result,fixed=TRUE)\r
+ result <- gsub("#","\\#",result,fixed=TRUE)\r
+ result <- gsub("^","\\verb|^|",result,fixed=TRUE)\r
+ result <- gsub("~","\\~{}",result,fixed=TRUE)\r
+ result <- gsub("SANITIZE.BACKSLASH","$\\backslash$",result,fixed=TRUE)\r
+ return(result)\r
+ }\r
+ sanitize.numbers <- function(x) {\r
+ result <- x\r
+ if ( math.style.negative ) {\r
+ # Jake Bowers <jwbowers@illinois.edu> in e-mail from 2008-08-20 suggested\r
+ # disabling this feature to avoid problems with LaTeX's dcolumn package.\r
+ # by Florian Wickelmaier <florian.wickelmaier@uni-tuebingen.de> in e-mail\r
+ # from 2008-10-03 requested the ability to use the old behavior.\r
+ for(i in 1:length(x)) {\r
+ result[i] <- gsub("-","$-$",result[i],fixed=TRUE)\r
+ }\r
+ }\r
+ return(result)\r
+ }\r
+ sanitize.final <- function(result) {\r
+ return(result)\r
+ }\r
+ } else {\r
+ BCOMMENT <- "<!-- "\r
+ ECOMMENT <- " -->\n"\r
+ BTABLE <- paste("<TABLE ",html.table.attributes,">\n",sep="")\r
+ ETABLE <- "</TABLE>\n"\r
+ BENVIRONMENT <- ""\r
+ EENVIRONMENT <- ""\r
+ BTABULAR <- ""\r
+ ETABULAR <- ""\r
+ BSIZE <- ""\r
+ ESIZE <- ""\r
+ BLABEL <- "<A NAME="\r
+ ELABEL <- "></A>\n"\r
+ BCAPTION <- paste("<CAPTION ALIGN=\"",caption.placement,"\"> ",sep="")\r
+ ECAPTION <- " </CAPTION>\n"\r
+ BROW <- "<TR>"\r
+ EROW <- " </TR>\n"\r
+ BTH <- " <TH> "\r
+ ETH <- " </TH> "\r
+ STH <- " </TH> <TH> "\r
+ BTD1 <- " <TD align=\""\r
+ align.tmp <- attr(x,"align",exact=TRUE)\r
+ align.tmp <- align.tmp[align.tmp!="|"]\r
+ BTD2 <- matrix(align.tmp[(2-pos):(ncol(x)+1)],nrow=nrow(x),ncol=ncol(x)+pos,byrow=TRUE)\r
+ # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007\r
+ BTD2[regexpr("^p",BTD2)>0] <- "left"\r
+ BTD2[BTD2=="r"] <- "right"\r
+ BTD2[BTD2=="l"] <- "left"\r
+ BTD2[BTD2=="c"] <- "center"\r
+ BTD3 <- "\"> "\r
+ ETD <- " </TD>"\r
+ sanitize <- function(str) {\r
+ result <- str\r
+ result <- gsub("&","& ",result,fixed=TRUE)\r
+ result <- gsub(">","> ",result,fixed=TRUE)\r
+ result <- gsub("<","< ",result,fixed=TRUE)\r
+ # Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05 recommended not escaping underscores.\r
+ # result <- gsub("_", "\\_", result, fixed=TRUE)\r
+ return(result)\r
+ }\r
+ sanitize.numbers <- function(x) {\r
+ return(x)\r
+ }\r
+ sanitize.final <- function(result) {\r
+ # Suggested by Uwe Ligges <ligges@statistik.uni-dortmund.de> in e-mail dated 2005-07-30.\r
+ result$text <- gsub(" *"," ", result$text,fixed=TRUE)\r
+ result$text <- gsub(' align="left"', "", result$text,fixed=TRUE)\r
+ return(result)\r
+ }\r
+ }\r
+\r
+ result <- string("",file=file,append=append)\r
+ info <- R.Version()\r
+ # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 to set automatically the package version\r
+ result <- result + BCOMMENT + type + " table generated in " +\r
+ info$language + " " + info$major + "." + info$minor + " by xtable " + packageDescription('xtable')$Version + " package" + ECOMMENT\r
+ result <- result + BCOMMENT + date() + ECOMMENT\r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 only.contents\r
+ if (!only.contents) {\r
+ result <- result + BTABLE\r
+ result <- result + BENVIRONMENT\r
+ if ( floating == TRUE ) {\r
+ if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="html" || caption.placement=="top")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION\r
+ if (!is.null(attr(x,"label",exact=TRUE)) && (type=="latex" && caption.placement=="top")) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL \r
+ }\r
+ result <- result + BSIZE\r
+ result <- result + BTABULAR\r
+ }\r
+ # Claudio Agostinelli <claudio@unive.it> dated 2006-07-28 include.colnames, include.rownames \r
+ if (include.colnames) {\r
+ result <- result + BROW + BTH\r
+ if (include.rownames) result <- result + STH\r
+ if (is.null(sanitize.colnames.function)) { # David G. Whiting in e-mail 2007-10-09\r
+ result <- result + paste(sanitize(names(x)),collapse=STH)\r
+ } else {\r
+ result <- result + paste(sanitize.colnames.function(names(x)), collapse=STH) # David G. Whiting in e-mail 2007-10-09\r
+ }\r
+ result <- result + ETH + EROW\r
+ }\r
+\r
+ cols <- matrix("",nrow=nrow(x),ncol=ncol(x)+pos)\r
+ if (include.rownames) {\r
+ if (is.null(sanitize.rownames.function)) { # David G. Whiting in e-mail 2007-10-09\r
+ cols[,1] <- sanitize(row.names(x))\r
+ } else {\r
+ cols[,1] <- sanitize.rownames.function(row.names(x)) # David G. Whiting in e-mail 2007-10-09\r
+ }\r
+ }\r
+\r
+## Begin vectorizing the formatting code by Ian Fellows [ian@fellstat.com]\r
+## 06 Dec 2011\r
+##\r
+# disp <- function(y) {\r
+# if (is.factor(y)) {\r
+# y <- levels(y)[y]\r
+# }\r
+# if (is.list(y)) {\r
+# y <- unlist(y)\r
+# }\r
+# return(y)\r
+# }\r
+ varying.digits <- is.matrix( attr( x, "digits",exact=TRUE ) )\r
+ # 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
+ #if( !varying.digits ) {\r
+ # modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
+ # attr(x,"digits") <- matrix( attr( x, "digits",exact=TRUE ), nrow = nrow(x), ncol = ncol(x)+1, byrow = TRUE )\r
+ #}\r
+ for(i in 1:ncol(x)) {\r
+ xcol <- x[,i]\r
+ if(is.factor(xcol))\r
+ xcol <- as.character(xcol)\r
+ if(is.list(xcol))\r
+ xcol <- sapply(xcol,unlist)\r
+ ina <- is.na(xcol)\r
+ is.numeric.column <- is.numeric(xcol)\r
+\r
+ if(is.character(xcol))\r
+ cols[,i+pos] <- xcol\r
+ else if(!varying.digits){\r
+ cols[,i+pos] <-\r
+ formatC( xcol,\r
+ format = ifelse( attr( x, "digits",exact=TRUE )[i+1] < 0, "E", \r
+ attr( x, "display",exact=TRUE )[i+1] ), \r
+ digits = abs( attr( x, "digits",exact=TRUE )[i+1] ), \r
+ decimal.mark=options()$OutDec)\r
+ }else{\r
+ for( j in 1:nrow( cols ) ) {\r
+ ### modified Claudio Agostinelli <claudio@unive.it> dated 2009-09-14\r
+ ### add decimal.mark=options()$OutDec\r
+ cols[j,i+pos] <-\r
+ formatC( xcol[j],\r
+ 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)\r
+ }\r
+ }\r
+ ## End Ian Fellows changes\r
+ \r
+ if ( any(ina) ) cols[ina,i+pos] <- NA.string\r
+ # Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007\r
+ if ( is.numeric.column ) {\r
+ cols[,i+pos] <- sanitize.numbers(cols[,i+pos])\r
+ } else {\r
+ if (is.null(sanitize.text.function)) {\r
+ cols[,i+pos] <- sanitize(cols[,i+pos])\r
+ } else {\r
+ cols[,i+pos] <- sanitize.text.function(cols[,i+pos])\r
+ }\r
+ }\r
+ }\r
+\r
+ multiplier <- 5\r
+ full <- matrix("",nrow=nrow(x),ncol=multiplier*(ncol(x)+pos)+2)\r
+ full[,1] <- BROW\r
+ full[,multiplier*(0:(ncol(x)+pos-1))+2] <- BTD1\r
+ full[,multiplier*(0:(ncol(x)+pos-1))+3] <- BTD2\r
+ full[,multiplier*(0:(ncol(x)+pos-1))+4] <- BTD3\r
+ full[,multiplier*(0:(ncol(x)+pos-1))+5] <- cols\r
+ full[,multiplier*(0:(ncol(x)+pos-1))+6] <- ETD\r
+\r
+ full[,multiplier*(ncol(x)+pos)+2] <- paste(EROW, lastcol[-(1:2)], sep=" ")\r
+ if (type=="latex") full[,2] <- ""\r
+ result <- result + lastcol[2] + paste(t(full),collapse="")\r
+ if (!only.contents) {\r
+ if (tabular.environment == "longtable") {\r
+ result <- result + PHEADER\r
+ ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the following 'if' condition is inserted in order to avoid\r
+ ## that bottom caption interferes with a top caption of a longtable\r
+ if(caption.placement=="bottom"){\r
+ if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION\r
+ }\r
+ if (!is.null(attr(x,"label",exact=TRUE))) result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL\r
+ ETABULAR <- "\\end{longtable}\n"\r
+ }\r
+ result <- result + ETABULAR\r
+ result <- result + ESIZE\r
+ if ( floating == TRUE ) {\r
+ if ((!is.null(attr(x,"caption",exact=TRUE))) && (type=="latex" && caption.placement=="bottom")) result <- result + BCAPTION + attr(x,"caption",exact=TRUE) + ECAPTION\r
+ if (!is.null(attr(x,"label",exact=TRUE)) && caption.placement=="bottom") result <- result + BLABEL + attr(x,"label",exact=TRUE) + ELABEL \r
+ }\r
+ result <- result + EENVIRONMENT\r
+ result <- result + ETABLE\r
+ } \r
+ result <- sanitize.final(result)\r
+ print(result)\r
+\r
+ return(invisible(result$text))\r
+}\r
+\r
+"+.string" <- function(x,y) {\r
+ x$text <- paste(x$text,as.string(y)$text,sep="")\r
+ return(x)\r
+}\r
+\r
+print.string <- function(x,...) {\r
+ cat(x$text,file=x$file,append=x$append)\r
+ return(invisible())\r
+}\r
+\r
+string <- function(text,file="",append=FALSE) {\r
+ x <- list(text=text,file=file,append=append)\r
+ class(x) <- "string"\r
+ return(x)\r
+}\r
+\r
+as.string <- function(x,file="",append=FALSE) {\r
+ if (is.null(attr(x,"class",exact=TRUE)))\r
+ switch(data.class(x),\r
+ character=return(string(x,file,append)),\r
+ numeric=return(string(as.character(x),file,append)),\r
+ stop("Cannot coerse argument to a string"))\r
+ if (class(x)=="string")\r
+ return(x)\r
+ stop("Cannot coerse argument to a string")\r
+}\r
+\r
+is.string <- function(x) {\r
+ return(class(x)=="string")\r
+}\r
+\r
projects / xtable.git / commitdiff