timestamp = getOption("xtable.timestamp", date()),\r
...)\r
{\r
- ## If caption is length 2, treat the second value as the "short caption"\r
- caption <- attr(x,"caption",exact = TRUE)\r
- short.caption <- NULL\r
- if (!is.null(caption) && length(caption) > 1){\r
- short.caption <- caption[2]\r
- caption <- caption[1]\r
- }\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\r
- ## 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\r
- ## 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,\r
- ## include.colnames\r
- pos <- 0\r
- if (include.rownames) pos <- 1\r
-\r
- ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
- ## hline.after checks\r
- if (any(hline.after < -1) | any(hline.after > nrow(x))) {\r
- stop("'hline.after' must be inside [-1, nrow(x)]")\r
- }\r
-\r
- ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
- ## 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,\r
- mode = 'character')) {\r
- if ((npos <- length(add.to.row$pos)) !=\r
- 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) |\r
- 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
+ ## If caption is length 2, treat the second value as the "short caption"\r
+ caption <- attr(x,"caption",exact = TRUE)\r
+ short.caption <- NULL\r
+ if (!is.null(caption) && length(caption) > 1){\r
+ short.caption <- caption[2]\r
+ caption <- caption[1]\r
+ }\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\r
+ ## 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\r
+ ## 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,\r
+ ## include.colnames\r
+ pos <- 0\r
+ if (include.rownames) pos <- 1\r
+ \r
+ ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
+ ## hline.after checks\r
+ if (any(hline.after < -1) | any(hline.after > nrow(x))) {\r
+ stop("'hline.after' must be inside [-1, nrow(x)]")\r
+ }\r
+ \r
+ ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
+ ## 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,\r
+ mode = 'character')) {\r
+ if ((npos <- length(add.to.row$pos)) !=\r
+ 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) |\r
+ 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
- add.to.row <- list(pos = list(),\r
- command = vector(length = 0, mode = "character"))\r
- npos <- 0\r
+ stop("'add.to.row' argument must be a list of length 2")\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
- ## Original code before changes in version 1.6-1\r
- ## PHEADER <- "\\hline\n"\r
-\r
- ## booktabs code from Matthieu Stigler <matthieu.stigler@gmail.com>,\r
- ## 1 Feb 2012\r
- if(!booktabs){\r
- PHEADER <- "\\hline\n"\r
- } else {\r
- ## This code replaced to fix bug #2309, David Scott, 8 Jan 2014\r
- ## PHEADER <- ifelse(-1%in%hline.after, "\\toprule\n", "")\r
- ## if(0%in%hline.after) {\r
- ## PHEADER <- c(PHEADER, "\\midrule\n")\r
- ## }\r
- ## if(nrow(x)%in%hline.after) {\r
- ## PHEADER <- c(PHEADER, "\\bottomrule\n")\r
- ## }\r
- if (is.null(hline.after)){\r
- PHEADER <- ""\r
- } else {\r
- hline.after <- sort(hline.after)\r
- PHEADER <- rep("\\midrule\n", length(hline.after))\r
- if (hline.after[1] == -1) {\r
- PHEADER[1] <- "\\toprule\n"\r
- }\r
- if (hline.after[length(hline.after)] == nrow(x)) {\r
- PHEADER[length(hline.after)] <- "\\bottomrule\n"\r
- }\r
- }\r
- }\r
+ } else {\r
+ add.to.row <- list(pos = list(),\r
+ 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
+ ## Original code before changes in version 1.6-1\r
+ ## PHEADER <- "\\hline\n"\r
+ \r
+ ## booktabs code from Matthieu Stigler <matthieu.stigler@gmail.com>,\r
+ ## 1 Feb 2012\r
+ if(!booktabs){\r
+ PHEADER <- "\\hline\n"\r
} else {\r
+ ## This code replaced to fix bug #2309, David Scott, 8 Jan 2014\r
+ ## PHEADER <- ifelse(-1%in%hline.after, "\\toprule\n", "")\r
+ ## if(0%in%hline.after) {\r
+ ## PHEADER <- c(PHEADER, "\\midrule\n")\r
+ ## }\r
+ ## if(nrow(x)%in%hline.after) {\r
+ ## PHEADER <- c(PHEADER, "\\bottomrule\n")\r
+ ## }\r
+ if (is.null(hline.after)){\r
PHEADER <- ""\r
- }\r
-\r
- lastcol <- rep(" ", nrow(x)+2)\r
- if (!is.null(hline.after)) {\r
- ## booktabs change - Matthieu Stigler: fill the hline arguments\r
- ## separately, 1 Feb 2012\r
- ##\r
- ## Code before booktabs change was:\r
- ## add.to.row$pos[[npos+1]] <- hline.after\r
-\r
- if (!booktabs){\r
- add.to.row$pos[[npos+1]] <- hline.after\r
- } else {\r
- for(i in 1:length(hline.after)) {\r
- add.to.row$pos[[npos+i]] <- hline.after[i]\r
- }\r
+ } else {\r
+ hline.after <- sort(hline.after)\r
+ PHEADER <- rep("\\midrule\n", length(hline.after))\r
+ if (hline.after[1] == -1) {\r
+ PHEADER[1] <- "\\toprule\n"\r
}\r
- add.to.row$command <- c(add.to.row$command, PHEADER)\r
- }\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],\r
- paste(rep(add.to.row$command[i],\r
- freq[j]),\r
- sep = "", collapse = ""),\r
- sep = " ")\r
- }\r
+ if (hline.after[length(hline.after)] == nrow(x)) {\r
+ PHEADER[length(hline.after)] <- "\\bottomrule\n"\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"))))) {\r
- stop("\"type\" must be in {\"latex\", \"html\"}")\r
- }\r
- ## Disabling the check on known floating environments as many users\r
- ## want to use additional environments.\r
- # if (!all(!is.na(match(floating.environment,\r
- # c("table","table*","sidewaystable",\r
- # "margintable"))))) {\r
- # stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}")\r
- # }\r
- if (("margintable" %in% floating.environment)\r
- & (!is.null(table.placement))) {\r
- warning("margintable does not allow for table placement; setting table.placement to NULL")\r
- table.placement <- NULL\r
+ } else {\r
+ PHEADER <- ""\r
+ }\r
+ \r
+ lastcol <- rep(" ", nrow(x)+2)\r
+ if (!is.null(hline.after)) {\r
+ ## booktabs change - Matthieu Stigler: fill the hline arguments\r
+ ## separately, 1 Feb 2012\r
+ ##\r
+ ## Code before booktabs change was:\r
+ ## add.to.row$pos[[npos+1]] <- hline.after\r
+ \r
+ if (!booktabs){\r
+ add.to.row$pos[[npos+1]] <- hline.after\r
+ } else {\r
+ for(i in 1:length(hline.after)) {\r
+ add.to.row$pos[[npos+i]] <- hline.after[i]\r
+ }\r
}\r
- if (!is.null(table.placement) &&\r
- !all(!is.na(match(unlist(strsplit(table.placement, split = "")),\r
- c("H","h","t","b","p","!"))))) {\r
- stop("\"table.placement\" must contain only elements of {\"h\",\"t\",\"b\",\"p\",\"!\"}")\r
+ add.to.row$command <- c(add.to.row$command, PHEADER)\r
+ }\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],\r
+ paste(rep(add.to.row$command[i],\r
+ freq[j]),\r
+ sep = "", collapse = ""),\r
+ sep = " ")\r
+ }\r
}\r
- if (!all(!is.na(match(caption.placement, c("bottom","top"))))) {\r
- stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")\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"))))) {\r
+ stop("\"type\" must be in {\"latex\", \"html\"}")\r
+ }\r
+ ## Disabling the check on known floating environments as many users\r
+ ## want to use additional environments.\r
+ ## if (!all(!is.na(match(floating.environment,\r
+ ## c("table","table*","sidewaystable",\r
+ ## "margintable"))))) {\r
+ ## stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}")\r
+ ## }\r
+ if (("margintable" %in% floating.environment)\r
+ & (!is.null(table.placement))) {\r
+ warning("margintable does not allow for table placement; setting table.placement to NULL")\r
+ table.placement <- NULL\r
+ }\r
+ if (!is.null(table.placement) &&\r
+ !all(!is.na(match(unlist(strsplit(table.placement, split = "")),\r
+ 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"))))) {\r
+ stop("\"caption.placement\" must be either {\"bottom\",\"top\"}")\r
+ }\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\r
+ ## regarding "texfloat"\r
+ ## See e-mail form "Fernando Henrique Ferraz P. da Rosa"\r
+ ## <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
-\r
- if (type == "latex") {\r
- BCOMMENT <- "% "\r
- ECOMMENT <- "\n"\r
- ## See e-mail from "John S. Walker <jsw9c@uic.edu>" dated 5-19-2003\r
- ## regarding "texfloat"\r
- ## See e-mail form "Fernando Henrique Ferraz P. da Rosa"\r
- ## <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>"\r
- ## dated 7-09-2003 regarding "suggestion for an amendment of\r
- ## the source"\r
- ## See e-mail from "Mitchell, David"\r
- ## <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding\r
- ## "Additions to R xtable package"\r
- ## See e-mail from "Garbade, Sven"\r
- ## <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22\r
- ## regarding the floating environment.\r
- BTABLE <- paste("\\begin{", floating.environment, "}",\r
- ifelse(!is.null(table.placement),\r
- paste("[", table.placement, "]", sep = ""),\r
- ""), "\n", sep = "")\r
- if ( is.null(latex.environments) ||\r
- (length(latex.environments) == 0) ) {\r
- BENVIRONMENT <- ""\r
- EENVIRONMENT <- ""\r
- } else {\r
- BENVIRONMENT <- ""\r
- EENVIRONMENT <- ""\r
- if ("center" %in% latex.environments){\r
- BENVIRONMENT <- paste(BENVIRONMENT, "\\centering\n",\r
- sep = "")\r
- }\r
- for (i in 1:length(latex.environments)) {\r
- if (latex.environments[i] == "") next\r
- if (latex.environments[i] != "center"){\r
- BENVIRONMENT <- paste(BENVIRONMENT,\r
- "\\begin{", latex.environments[i],\r
- "}\n", sep = "")\r
- EENVIRONMENT <- paste("\\end{", latex.environments[i],\r
- "}\n", EENVIRONMENT, sep = "")\r
- }\r
- }\r
- }\r
- ETABLE <- paste("\\end{", floating.environment, "}\n", sep = "")\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] == '|' )\r
- tmp.index.start <- tmp.index.start + 1\r
- tmp.index.start <- tmp.index.start + 1\r
- }\r
- ## Added "width" argument for use with "tabular*" or\r
- ## "tabularx" environments - CR, 7/2/12\r
- if (is.null(width)){\r
- WIDTH <-""\r
- } else if (is.element(tabular.environment,\r
- c("tabular", "longtable"))){\r
- 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
- WIDTH <- ""\r
- } else {\r
- WIDTH <- paste("{", width, "}", sep = "")\r
- }\r
-\r
- BTABULAR <-\r
- paste("\\begin{", tabular.environment, "}",\r
- WIDTH, "{",\r
- paste(c(attr(x, "align",\r
- exact = TRUE)[\r
- tmp.index.start:length(attr(x, "align",\r
- exact = TRUE))],\r
- "}\n"),\r
- sep = "", collapse = ""),\r
- sep = "")\r
-\r
- ## fix 10-26-09 (robert.castelo@upf.edu) the following\r
- ## '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
- if (is.null(short.caption)){\r
- BCAPTION <- "\\caption{"\r
- } else {\r
- BCAPTION <- paste("\\caption[", short.caption, "]{", sep = "")\r
- }\r
- ECAPTION <- "} \\\\ \n"\r
- if ((!is.null(caption)) && (type == "latex")) {\r
- BTABULAR <- paste(BTABULAR, BCAPTION, caption, ECAPTION,\r
- sep = "")\r
- }\r
- }\r
- ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
- ## 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
- ## Add scalebox - CR, 7/2/12\r
- if (!is.null(scalebox)){\r
- BTABULAR <- paste("\\scalebox{", scalebox, "}{\n", BTABULAR,\r
- sep = "")\r
- ETABULAR <- paste(ETABULAR, "}\n", sep = "")\r
- }\r
-\r
- ## BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail\r
- ## 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
- ## Added caption width (jeff.laake@nooa.gov)\r
- if(!is.null(caption.width)){\r
- BCAPTION <- paste("\\parbox{",caption.width,"}{",sep="")\r
- ECAPTION <- "}"\r
- } else {\r
- BCAPTION <- NULL\r
- ECAPTION <- NULL\r
- }\r
- if (is.null(short.caption)){\r
- BCAPTION <- paste(BCAPTION,"\\caption{",sep="")\r
- } else {\r
- BCAPTION <- paste(BCAPTION,"\\caption[", short.caption, "]{", sep="")\r
- }\r
- ECAPTION <- paste(ECAPTION,"} \n",sep="")\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\r
- ## <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$",\r
- 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\r
- ## from 2008-08-20 suggested disabling this feature to avoid\r
- ## problems with LaTeX's dcolumn package.\r
- ## by Florian Wickelmaier <florian.wickelmaier@uni-tuebingen.de>\r
- ## in e-mail from 2008-10-03 requested the ability to use the\r
- ## 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
+ if ( floating == TRUE ) {\r
+ ## See e-mail from "Pfaff, Bernhard <Bernhard.Pfaff@drkw.com>"\r
+ ## dated 7-09-2003 regarding "suggestion for an amendment of\r
+ ## the source"\r
+ ## See e-mail from "Mitchell, David"\r
+ ## <David.Mitchell@dotars.gov.au>" dated 2003-07-09 regarding\r
+ ## "Additions to R xtable package"\r
+ ## See e-mail from "Garbade, Sven"\r
+ ## <Sven.Garbade@med.uni-heidelberg.de> dated 2006-05-22\r
+ ## regarding the floating environment.\r
+ BTABLE <- paste("\\begin{", floating.environment, "}",\r
+ ifelse(!is.null(table.placement),\r
+ paste("[", table.placement, "]", sep = ""),\r
+ ""), "\n", sep = "")\r
+ if ( is.null(latex.environments) ||\r
+ (length(latex.environments) == 0) ) {\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, "\"> ",\r
- 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)],\r
- nrow = nrow(x), ncol = ncol(x)+pos, byrow = TRUE)\r
- ## Based on contribution from Jonathan Swinton <jonathan@swintons.net>\r
- ## 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
- ## Changed as suggested in bug report #2795\r
- ## That is replacement of "&" is "&"\r
- ## instead of previous "&" etc\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
- ## Kurt Hornik <Kurt.Hornik@wu-wien.ac.at> on 2006/10/05\r
- ## recommended not escaping underscores.\r
- ## result <- gsub("_", "\\_", result, fixed=TRUE)\r
- return(result)\r
- }\r
- sanitize.numbers <- function(x) {\r
- return(x)\r
+ } else {\r
+ BENVIRONMENT <- ""\r
+ EENVIRONMENT <- ""\r
+ if ("center" %in% latex.environments){\r
+ BENVIRONMENT <- paste(BENVIRONMENT, "\\centering\n",\r
+ sep = "")\r
}\r
- sanitize.final <- function(result) {\r
- ## Suggested by Uwe Ligges <ligges@statistik.uni-dortmund.de>\r
- ## in e-mail dated 2005-07-30.\r
- result$text <- gsub(" *", " ", result$text, fixed = TRUE)\r
- result$text <- gsub(' align="left"', "", result$text,\r
- fixed = TRUE)\r
- return(result)\r
+ for (i in 1:length(latex.environments)) {\r
+ if (latex.environments[i] == "") next\r
+ if (latex.environments[i] != "center"){\r
+ BENVIRONMENT <- paste(BENVIRONMENT,\r
+ "\\begin{", latex.environments[i],\r
+ "}\n", sep = "")\r
+ EENVIRONMENT <- paste("\\end{", latex.environments[i],\r
+ "}\n", EENVIRONMENT, sep = "")\r
+ }\r
}\r
+ }\r
+ ETABLE <- paste("\\end{", floating.environment, "}\n", sep = "")\r
+ } else {\r
+ BTABLE <- ""\r
+ ETABLE <- ""\r
+ BENVIRONMENT <- ""\r
+ EENVIRONMENT <- ""\r
}\r
-\r
- result <- string("", file = file, append = append)\r
- info <- R.Version()\r
- ## modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
- ## to set automatically the package version\r
- if (comment){\r
- result <- result + BCOMMENT + type + " table generated in " +\r
- info$language + " " + info$major + "." + info$minor +\r
- " by xtable " + packageDescription('xtable')$Version +\r
- " package" + ECOMMENT\r
- if (!is.null(timestamp)){\r
- result <- result + BCOMMENT + timestamp + ECOMMENT\r
- }\r
+ \r
+ tmp.index.start <- 1\r
+ if ( ! include.rownames ) {\r
+ while ( attr(x, "align", exact = TRUE)[tmp.index.start] == '|' )\r
+ tmp.index.start <- tmp.index.start + 1\r
+ tmp.index.start <- tmp.index.start + 1\r
}\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(caption)) &&\r
- (type == "html" ||caption.placement == "top")) {\r
- result <- result + BCAPTION + caption + ECAPTION\r
- }\r
- if (!is.null(attr(x, "label", exact = TRUE)) &&\r
- (type == "latex" && caption.placement == "top")) {\r
- result <- result + BLABEL +\r
- attr(x, "label", exact = TRUE) + ELABEL\r
- }\r
- }\r
- result <- result + BSIZE\r
- result <- result + BTABULAR\r
+ ## Added "width" argument for use with "tabular*" or\r
+ ## "tabularx" environments - CR, 7/2/12\r
+ if (is.null(width)){\r
+ WIDTH <-""\r
+ } else if (is.element(tabular.environment,\r
+ c("tabular", "longtable"))){\r
+ 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
+ WIDTH <- ""\r
+ } else {\r
+ WIDTH <- paste("{", width, "}", sep = "")\r
+ }\r
+ \r
+ BTABULAR <-\r
+ paste("\\begin{", tabular.environment, "}",\r
+ WIDTH, "{",\r
+ paste(c(attr(x, "align",\r
+ exact = TRUE)[\r
+ tmp.index.start:length(attr(x, "align",\r
+ exact = TRUE))],\r
+ "}\n"),\r
+ sep = "", collapse = ""),\r
+ sep = "")\r
+ \r
+ ## fix 10-26-09 (robert.castelo@upf.edu) the following\r
+ ## '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
+ if (is.null(short.caption)){\r
+ BCAPTION <- "\\caption{"\r
+ } else {\r
+ BCAPTION <- paste("\\caption[", short.caption, "]{", sep = "")\r
+ }\r
+ ECAPTION <- "} \\\\ \n"\r
+ if ((!is.null(caption)) && (type == "latex")) {\r
+ BTABULAR <- paste(BTABULAR, BCAPTION, caption, ECAPTION,\r
+ sep = "")\r
+ }\r
}\r
## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
- ## include.colnames, include.rownames\r
- if (include.colnames) {\r
- result <- result + BROW + BTH\r
- if (include.rownames) {\r
- result <- result + STH\r
- }\r
- ## David G. Whiting in e-mail 2007-10-09\r
- if (is.null(sanitize.colnames.function)) {\r
- CNAMES <- sanitize(names(x))\r
- } else {\r
- CNAMES <- sanitize.colnames.function(names(x))\r
- }\r
- if (rotate.colnames) {\r
- ##added by Markus Loecher, 2009-11-16\r
- CNAMES <- paste("\\begin{sideways}", CNAMES, "\\end{sideways}")\r
- }\r
- result <- result + paste(CNAMES, collapse = STH)\r
-\r
- result <- result + ETH + EROW\r
+ ## 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
+ ## Add scalebox - CR, 7/2/12\r
+ if (!is.null(scalebox)){\r
+ BTABULAR <- paste("\\scalebox{", scalebox, "}{\n", BTABULAR,\r
+ sep = "")\r
+ ETABULAR <- paste(ETABULAR, "}\n", sep = "")\r
}\r
-\r
- cols <- matrix("", nrow = nrow(x), ncol = ncol(x)+pos)\r
+ \r
+ ## BSIZE contributed by Benno <puetz@mpipsykl.mpg.de> in e-mail\r
+ ## 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
+ ## Added caption width (jeff.laake@nooa.gov)\r
+ if(!is.null(caption.width)){\r
+ BCAPTION <- paste("\\parbox{",caption.width,"}{",sep="")\r
+ ECAPTION <- "}"\r
+ } else {\r
+ BCAPTION <- NULL\r
+ ECAPTION <- NULL\r
+ }\r
+ if (is.null(short.caption)){\r
+ BCAPTION <- paste(BCAPTION,"\\caption{",sep="")\r
+ } else {\r
+ BCAPTION <- paste(BCAPTION,"\\caption[", short.caption, "]{", sep="")\r
+ }\r
+ ECAPTION <- paste(ECAPTION,"} \n",sep="")\r
+ BROW <- ""\r
+ EROW <- " \\\\ \n"\r
+ BTH <- ""\r
+ ETH <- ""\r
+ STH <- " & "\r
+ BTD1 <- " & "\r
+ BTD2 <- ""\r
+ BTD3 <- ""\r
+ ETD <- ""\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, "\"> ",\r
+ 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)],\r
+ nrow = nrow(x), ncol = ncol(x)+pos, byrow = TRUE)\r
+ ## Based on contribution from Jonathan Swinton <jonathan@swintons.net>\r
+ ## 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
+ }\r
+ \r
+ result <- string("", file = file, append = append)\r
+ info <- R.Version()\r
+ ## modified Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
+ ## to set automatically the package version\r
+ if (comment){\r
+ result <- result + BCOMMENT + type + " table generated in " +\r
+ info$language + " " + info$major + "." + info$minor +\r
+ " by xtable " + packageDescription('xtable')$Version +\r
+ " package" + ECOMMENT\r
+ if (!is.null(timestamp)){\r
+ result <- result + BCOMMENT + timestamp + ECOMMENT\r
+ }\r
+ }\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(caption)) &&\r
+ (type == "html" ||caption.placement == "top")) {\r
+ result <- result + BCAPTION + caption + ECAPTION\r
+ }\r
+ if (!is.null(attr(x, "label", exact = TRUE)) &&\r
+ (type == "latex" && caption.placement == "top")) {\r
+ result <- result + BLABEL +\r
+ attr(x, "label", exact = TRUE) + ELABEL\r
+ }\r
+ }\r
+ result <- result + BSIZE\r
+ result <- result + BTABULAR\r
+ }\r
+ ## Claudio Agostinelli <claudio@unive.it> dated 2006-07-28\r
+ ## include.colnames, include.rownames\r
+ if (include.colnames) {\r
+ result <- result + BROW + BTH\r
if (include.rownames) {\r
- ## David G. Whiting in e-mail 2007-10-09\r
- if (is.null(sanitize.rownames.function)) {\r
- RNAMES <- sanitize(row.names(x))\r
- } else {\r
- RNAMES <- sanitize.rownames.function(row.names(x))\r
- }\r
- if (rotate.rownames) {\r
- ##added by Markus Loecher, 2009-11-16\r
- RNAMES <- paste("\\begin{sideways}", RNAMES, "\\end{sideways}")\r
- }\r
- cols[, 1] <- RNAMES\r
+ result <- result + STH\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\r
- ## Arne Henningsen <ahenningsen@agric-econ.uni-kiel.de>\r
- ## 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 ),\r
- ## 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 {\r
- if (is.null(format.args)){\r
- format.args <- list()\r
- }\r
- if (is.null(format.args$decimal.mark)){\r
- format.args$decimal.mark <- options()$OutDec\r
- }\r
- if(!varying.digits){\r
- curFormatArgs <-\r
- c(list(\r
- x = xcol,\r
- format =\r
- 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
- format.args)\r
- cols[, i+pos] <- do.call("formatC", curFormatArgs)\r
- }else{\r
- for( j in 1:nrow( cols ) ) {\r
- curFormatArgs <-\r
- c(list(\r
- x = xcol[j],\r
- format =\r
- ifelse(attr(x, "digits", exact = TRUE )[j, i+1] < 0,\r
- "E", attr(x, "display", exact = TRUE )[i+1]),\r
- digits =\r
- abs(attr(x, "digits", exact = TRUE )[j, i+1])),\r
- format.args)\r
- cols[j, i+pos] <- do.call("formatC", curFormatArgs)\r
- }\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>\r
- ## 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
+ ## David G. Whiting in e-mail 2007-10-09\r
+ if (is.null(sanitize.colnames.function)) {\r
+ CNAMES <- sanitize(names(x), type = type)\r
+ } else {\r
+ CNAMES <- sanitize.colnames.function(names(x))\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)],\r
- sep = " ")\r
-\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
- ## booktabs change added the if() - 1 Feb 2012\r
- if(!booktabs) {\r
- result <- result + PHEADER\r
- }\r
-\r
- ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the\r
- ## 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(caption)) && (type == "latex")) {\r
- result <- result + BCAPTION + caption + ECAPTION\r
- }\r
- }\r
- if (!is.null(attr(x, "label", exact = TRUE))) {\r
- result <- result + BLABEL + attr(x, "label", exact = TRUE) +\r
- ELABEL\r
- }\r
- ETABULAR <- "\\end{longtable}\n"\r
+ if (rotate.colnames) {\r
+ ##added by Markus Loecher, 2009-11-16\r
+ CNAMES <- paste("\\begin{sideways}", CNAMES, "\\end{sideways}")\r
+ }\r
+ result <- result + paste(CNAMES, collapse = STH)\r
+ \r
+ result <- result + ETH + EROW\r
+ }\r
+ \r
+ cols <- matrix("", nrow = nrow(x), ncol = ncol(x)+pos)\r
+ if (include.rownames) {\r
+ ## David G. Whiting in e-mail 2007-10-09\r
+ if (is.null(sanitize.rownames.function)) {\r
+ RNAMES <- sanitize(row.names(x), type = type)\r
+ } else {\r
+ RNAMES <- sanitize.rownames.function(row.names(x))\r
+ }\r
+ if (rotate.rownames) {\r
+ ##added by Markus Loecher, 2009-11-16\r
+ RNAMES <- paste("\\begin{sideways}", RNAMES, "\\end{sideways}")\r
+ }\r
+ cols[, 1] <- RNAMES\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\r
+ ## Arne Henningsen <ahenningsen@agric-econ.uni-kiel.de>\r
+ ## 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 ),\r
+ ## 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 {\r
+ if (is.null(format.args)){\r
+ format.args <- list()\r
+ }\r
+ if (is.null(format.args$decimal.mark)){\r
+ format.args$decimal.mark <- options()$OutDec\r
+ }\r
+ if(!varying.digits){\r
+ curFormatArgs <-\r
+ c(list(\r
+ x = xcol,\r
+ format =\r
+ 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
+ format.args)\r
+ cols[, i+pos] <- do.call("formatC", curFormatArgs)\r
+ }else{\r
+ for( j in 1:nrow( cols ) ) {\r
+ curFormatArgs <-\r
+ c(list(\r
+ x = xcol[j],\r
+ format =\r
+ ifelse(attr(x, "digits", exact = TRUE )[j, i+1] < 0,\r
+ "E", attr(x, "display", exact = TRUE )[i+1]),\r
+ digits =\r
+ abs(attr(x, "digits", exact = TRUE )[j, i+1])),\r
+ format.args)\r
+ cols[j, i+pos] <- do.call("formatC", curFormatArgs)\r
}\r
- result <- result + ETABULAR\r
- result <- result + ESIZE\r
- if ( floating == TRUE ) {\r
- if ((!is.null(caption)) &&\r
- (type == "latex" && caption.placement == "bottom")) {\r
- result <- result + BCAPTION + caption + ECAPTION\r
- }\r
- if (!is.null(attr(x, "label", exact = TRUE)) &&\r
- caption.placement == "bottom") {\r
- result <- result + BLABEL + attr(x, "label", exact = TRUE) +\r
- ELABEL\r
- }\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>\r
+ ## in e-mail dated Wednesday, January 17, 2007\r
+ if ( is.numeric.column ) {\r
+ cols[, i+pos] <-\r
+ sanitize.numbers(cols[, i+pos], type = type,\r
+ math.style.negative = math.style.negative)\r
+ } else {\r
+ if (is.null(sanitize.text.function)) {\r
+ cols[, i+pos] <- sanitize(cols[, i+pos], type = type)\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)],\r
+ sep = " ")\r
+ \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
+ ## booktabs change added the if() - 1 Feb 2012\r
+ if(!booktabs) {\r
+ result <- result + PHEADER\r
+ }\r
+\r
+ ## fix 10-27-09 Liviu Andronic (landronimirc@gmail.com) the\r
+ ## 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(caption)) && (type == "latex")) {\r
+ result <- result + BCAPTION + caption + ECAPTION\r
}\r
- result <- result + EENVIRONMENT\r
- result <- result + ETABLE\r
+ }\r
+ if (!is.null(attr(x, "label", exact = TRUE))) {\r
+ result <- result + BLABEL + attr(x, "label", exact = TRUE) +\r
+ ELABEL\r
+ }\r
+ ETABULAR <- "\\end{longtable}\n"\r
}\r
- result <- sanitize.final(result)\r
-\r
- if (print.results){\r
- print(result)\r
+ result <- result + ETABULAR\r
+ result <- result + ESIZE\r
+ if ( floating == TRUE ) {\r
+ if ((!is.null(caption)) &&\r
+ (type == "latex" && caption.placement == "bottom")) {\r
+ result <- result + BCAPTION + caption + ECAPTION\r
+ }\r
+ if (!is.null(attr(x, "label", exact = TRUE)) &&\r
+ caption.placement == "bottom") {\r
+ result <- result + BLABEL + attr(x, "label", exact = TRUE) +\r
+ ELABEL\r
+ }\r
}\r
-\r
- return(invisible(result$text))\r
+ result <- result + EENVIRONMENT\r
+ result <- result + ETABLE\r
+ }\r
+ result <- sanitize.final(result, type = type)\r
+ \r
+ if (print.results){\r
+ print(result)\r
+ }\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
+ 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
+ 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
+ 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 coerce argument to a string"))\r
- if (class(x) == "string")\r
- return(x)\r
- stop("Cannot coerce argument to a string")\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 coerce argument to a string"))\r
+ if (class(x) == "string")\r
+ return(x)\r
+ stop("Cannot coerce argument to a string")\r
}\r
\r
is.string <- function(x) {\r
- return(class(x) == "string")\r
+ return(class(x) == "string")\r
}\r
\r
### Function to create lists of tables\r
xtableList <- function(x, caption = NULL, label = NULL, align = NULL,\r
- digits = NULL, display = NULL, ...) {\r
+ digits = NULL, display = NULL, ...) {\r
if (is.null(digits)){\r
digitsList <- vector("list", length(x))\r
} else {\r
...)\r
{\r
## Get number of rows for each table in list of tables\r
- if (booktabs){\r
- tRule <- "\\toprule"\r
- mRule <- "\\midrule"\r
- bRule <- "\\bottomrule"\r
- } else {\r
- tRule <- "\\hline"\r
- mRule <- "\\hline"\r
- bRule <- "\\hline"\r
- }\r
nCols <- dim(x[[1]])[2]\r
rowNums <- sapply(x, dim)[1,]\r
combinedRowNums <- cumsum(rowNums)\r
combined <- do.call(rbind, x)\r
- if (colnames.format == "single"){\r
- add.to.row <- list(pos = NULL, command = NULL)\r
- add.to.row$pos <- as.list(c(0, combinedRowNums[-length(x)],\r
- dim(combined)[1]))\r
- command <- sapply(x, attr, "subheading")\r
-\r
- add.to.row$command[1:length(x)] <-\r
- paste0(mRule,"\n\\multicolumn{", nCols, "}{l}{", command, "}\\\\\n")\r
- if ( (booktabs) & length(attr(x, "message") > 0) ){\r
- attr(x, "message")[1] <-\r
- paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
- }\r
- add.to.row$command[length(x) + 1] <-\r
- paste0("\n\\multicolumn{", nCols, "}{l}{", attr(x, "message"), "}\\\\\n",\r
- collapse = "")\r
- add.to.row$command[length(x) + 1] <-\r
- paste0(bRule, add.to.row$command[length(x) + 1])\r
-\r
- class(combined) <- c("xtableList", "data.frame")\r
- hline.after <- c(-1)\r
- include.colnames <- TRUE\r
- }\r
-\r
- ## Create headings for columns if multiple headings are needed\r
- if (colnames.format == "multiple"){\r
- if (is.null(sanitize.colnames.function)) {\r
- colHead <- names(x[[1]])\r
+ if (type == "latex"){\r
+ ## Special treatment if using booktabs\r
+ if (booktabs){\r
+ tRule <- "\\toprule"\r
+ mRule <- "\\midrule"\r
+ bRule <- "\\bottomrule"\r
} else {\r
- colHead <- sanitize.colnames.function(names(x[[1]]))\r
+ tRule <- "\\hline"\r
+ mRule <- "\\hline"\r
+ bRule <- "\\hline"\r
}\r
- if (rotate.colnames) {\r
- colHead <- paste("\\begin{sideways}", colHead, "\\end{sideways}")\r
+ if (colnames.format == "single"){\r
+ add.to.row <- list(pos = NULL, command = NULL)\r
+ add.to.row$pos <- as.list(c(0, combinedRowNums[-length(x)],\r
+ dim(combined)[1]))\r
+ command <- sapply(x, attr, "subheading")\r
+ \r
+ add.to.row$command[1:length(x)] <-\r
+ paste0(mRule,"\n\\multicolumn{", nCols, "}{l}{", command, "}\\\\\n")\r
+ if ( (booktabs) & length(attr(x, "message") > 0) ){\r
+ attr(x, "message")[1] <-\r
+ paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
+ }\r
+ add.to.row$command[length(x) + 1] <-\r
+ paste0("\n\\multicolumn{", nCols, "}{l}{",\r
+ attr(x, "message"), "}\\\\\n",\r
+ collapse = "")\r
+ add.to.row$command[length(x) + 1] <-\r
+ paste0(bRule, add.to.row$command[length(x) + 1])\r
+ \r
+ class(combined) <- c("xtableList", "data.frame")\r
+ hline.after <- c(-1)\r
+ include.colnames <- TRUE\r
}\r
- colHead <- paste0(colHead, collapse = " & ")\r
- if (include.rownames) {\r
- colHead <- paste0(" & ", colHead)\r
- }\r
- colHead <- paste0(tRule, "\n", colHead, " \\\\", mRule, "\n")\r
- add.to.row <- list(pos = NULL, command = NULL)\r
- add.to.row$pos <- as.list(c(0, c(combinedRowNums[1:length(x)])))\r
- command <- sapply(x, attr, "subheading")\r
- add.to.row$command[1] <-\r
- paste0("\n\\multicolumn{", nCols, "}{l}{", command[1], "}", " \\\\ \n",\r
- colHead)\r
- add.to.row$command[2:length(x)] <-\r
- paste0(bRule,\r
- "\\\\ \n\\multicolumn{", nCols, "}{l}{",\r
- command[2:length(x)], "}",\r
- "\\\\ \n",\r
- colHead)\r
- if ( (booktabs) & length(attr(x, "message") > 0) ){\r
- attr(x, "message")[1] <-\r
- paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
- }\r
- add.to.row$command[length(x) + 1] <-\r
- paste0("\n\\multicolumn{", nCols, "}{l}{", attr(x, "message"), "}\\\\\n",\r
- collapse = "")\r
- add.to.row$command[length(x) + 1] <-\r
- paste0(bRule, add.to.row$command[length(x) + 1])\r
\r
- class(combined) <- c("xtableList", "data.frame")\r
- hline.after <- NULL\r
-\r
- include.colnames <- FALSE\r
+ ## Create headings for columns if multiple headings are needed\r
+ if (colnames.format == "multiple"){\r
+ if (is.null(sanitize.colnames.function)) {\r
+ colHead <- names(x[[1]])\r
+ } else {\r
+ colHead <- sanitize.colnames.function(names(x[[1]]))\r
+ }\r
+ if (rotate.colnames) {\r
+ colHead <- paste("\\begin{sideways}", colHead, "\\end{sideways}")\r
+ }\r
+ colHead <- paste0(colHead, collapse = " & ")\r
+ if (include.rownames) {\r
+ colHead <- paste0(" & ", colHead)\r
+ }\r
+ colHead <- paste0(tRule, "\n", colHead, " \\\\", mRule, "\n")\r
+ add.to.row <- list(pos = NULL, command = NULL)\r
+ add.to.row$pos <- as.list(c(0, c(combinedRowNums[1:length(x)])))\r
+ command <- sapply(x, attr, "subheading")\r
+ add.to.row$command[1] <-\r
+ paste0("\n\\multicolumn{", nCols, "}{l}{", command[1], "}", " \\\\ \n",\r
+ colHead)\r
+ add.to.row$command[2:length(x)] <-\r
+ paste0(bRule,\r
+ "\\\\ \n\\multicolumn{", nCols, "}{l}{",\r
+ command[2:length(x)], "}",\r
+ "\\\\ \n",\r
+ colHead)\r
+ if ( (booktabs) & length(attr(x, "message") > 0) ){\r
+ attr(x, "message")[1] <-\r
+ paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1])\r
+ }\r
+ add.to.row$command[length(x) + 1] <-\r
+ paste0("\n\\multicolumn{", nCols, "}{l}{",\r
+ attr(x, "message"), "}\\\\\n",\r
+ collapse = "")\r
+ add.to.row$command[length(x) + 1] <-\r
+ paste0(bRule, add.to.row$command[length(x) + 1])\r
+ \r
+ class(combined) <- c("xtableList", "data.frame")\r
+ hline.after <- NULL\r
+ \r
+ include.colnames <- FALSE\r
+ }\r
+ \r
+ print.xtable(combined,\r
+ type = type,\r
+ floating = floating,\r
+ floating.environment = floating.environment,\r
+ table.placement = table.placement,\r
+ caption.placement = caption.placement,\r
+ caption.width = caption.width,\r
+ latex.environments = latex.environments,\r
+ tabular.environment = tabular.environment,\r
+ size = size,\r
+ hline.after = hline.after,\r
+ NA.string = NA.string,\r
+ include.rownames = include.rownames,\r
+ include.colnames = include.colnames,\r
+ only.contents = only.contents,\r
+ add.to.row = add.to.row,\r
+ sanitize.text.function = sanitize.text.function,\r
+ sanitize.rownames.function = sanitize.rownames.function,\r
+ sanitize.colnames.function = sanitize.colnames.function,\r
+ math.style.negative = math.style.negative,\r
+ html.table.attributes = html.table.attributes,\r
+ print.results = print.results,\r
+ format.args = format.args,\r
+ rotate.rownames = rotate.rownames,\r
+ rotate.colnames = rotate.colnames,\r
+ booktabs = booktabs,\r
+ scalebox = scalebox,\r
+ width = width,\r
+ comment = comment,\r
+ timestamp = timestamp,\r
+ ...)\r
+ } else {\r
+ stop("print.xtableList not yet implemented for this type")\r
}\r
-\r
- print.xtable(combined,\r
- type = type,\r
- floating = floating,\r
- floating.environment = floating.environment,\r
- table.placement = table.placement,\r
- caption.placement = caption.placement,\r
- caption.width = caption.width,\r
- latex.environments = latex.environments,\r
- tabular.environment = tabular.environment,\r
- size = size,\r
- hline.after = hline.after,\r
- NA.string = NA.string,\r
- include.rownames = include.rownames,\r
- include.colnames = include.colnames,\r
- only.contents = only.contents,\r
- add.to.row = add.to.row,\r
- sanitize.text.function = sanitize.text.function,\r
- sanitize.rownames.function = sanitize.rownames.function,\r
- sanitize.colnames.function = sanitize.colnames.function,\r
- math.style.negative = math.style.negative,\r
- html.table.attributes = html.table.attributes,\r
- print.results = print.results,\r
- format.args = format.args,\r
- rotate.rownames = rotate.rownames,\r
- rotate.colnames = rotate.colnames,\r
- booktabs = booktabs,\r
- scalebox = scalebox,\r
- width = width,\r
- comment = comment,\r
- timestamp = timestamp,\r
- ...)\r
-\r
}\r
\r
\r
### Uses xtableList\r
xtableLSMeans <- function(x, caption = NULL, label = NULL,\r
- align = NULL, digits = NULL,\r
- display = NULL, auto = FALSE,\r
- ...){\r
+ align = NULL, digits = NULL,\r
+ display = NULL, auto = FALSE,\r
+ ...){\r
if (attr(x, "estName") == "lsmean"){\r
xList <- split(x, f = x[, 2])\r
for (i in 1:length(xList)){\r
} else {\r
xList <- x\r
xList <- xtable.data.frame(xList, caption = caption, label = label,\r
- align = align, digits = digits,\r
- display = display, auto = auto, ...)\r
+ align = align, digits = digits,\r
+ display = display, auto = auto, ...)\r
}\r
return(xList)\r
}\r
projects / xtable.git / commitdiff