From: dscott Date: Fri, 8 Jan 2016 03:37:05 +0000 (+0000) Subject: Extracted sanitize functions and exported them X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=22a800457f5feecae5e947d91e52d29a7169d48a;p=xtable.git Extracted sanitize functions and exported them git-svn-id: svn://scm.r-forge.r-project.org/svnroot/xtable@83 edb9625f-4e0d-4859-8d74-9fd3b1da38cb --- diff --git a/pkg/DESCRIPTION b/pkg/DESCRIPTION index 6c34678..098d922 100644 --- a/pkg/DESCRIPTION +++ b/pkg/DESCRIPTION @@ -1,6 +1,6 @@ Package: xtable -Version: 1.8-1 -Date: 2015-12-09 +Version: 1.8-2 +Date: 2016-01-08 Title: Export Tables to LaTeX or HTML Author: David B. Dahl Maintainer: David Scott diff --git a/pkg/NAMESPACE b/pkg/NAMESPACE index 3ba56cb..810fa7f 100644 --- a/pkg/NAMESPACE +++ b/pkg/NAMESPACE @@ -8,7 +8,8 @@ export("caption<-", "caption", "label", "label<-", "xtableMatharray","xtableList", "xtableLSMeans", "print.xtable", "print.xtableMatharray", "print.xtableList", "toLatex.xtable", - "autoformat", "xalign", "xdigits", "xdisplay") + "autoformat", "xalign", "xdigits", "xdisplay", + "sanitize", "sanitize.numbers", "sanitize.final") S3method("print", "xtable") S3method("print", "xtableMatharray") diff --git a/pkg/NEWS b/pkg/NEWS index 7228e64..fba8404 100644 --- a/pkg/NEWS +++ b/pkg/NEWS @@ -1,11 +1,14 @@ 1.8-1 (NOT YET SUBMITTED TO CRAN) - * added function print.xtableMatharray to enable easy creation of + * Added function print.xtableMatharray to enable easy creation of LaTeX code to enable an array to be included in a document. - * added example to the gallery using sanitizing headings and row + * Added example to the gallery using sanitizing headings and row names to produce large bold headings and italic row names. - * added code from Martin Gubri, martin.gubri@framasoft.org, to produce - tables from the spatial econometrics packages, spdep, splm, and - sphet. + * Added code from Martin Gubri, martin.gubri@framasoft.org, to produce + tables from the spatial econometrics packages, spdep, splm, and + sphet. + * Extracted sanitize functions from print.xtable as stand-alone + functions, and exported them. + 1.8-0 * autoformat, xalign, xdigits, xdisplay from Arni Magnusson, added diff --git a/pkg/R/print.xtable.R b/pkg/R/print.xtable.R index 67f48d5..1cbf37f 100644 --- a/pkg/R/print.xtable.R +++ b/pkg/R/print.xtable.R @@ -57,648 +57,584 @@ print.xtable <- function(x, timestamp = getOption("xtable.timestamp", date()), ...) { - ## If caption is length 2, treat the second value as the "short caption" - caption <- attr(x,"caption",exact = TRUE) - short.caption <- NULL - if (!is.null(caption) && length(caption) > 1){ - short.caption <- caption[2] - caption <- caption[1] - } - - ## Claudio Agostinelli 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 dated 2006-07-28 include.rownames, - ## include.colnames - pos <- 0 - if (include.rownames) pos <- 1 - - ## Claudio Agostinelli 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 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") + ## If caption is length 2, treat the second value as the "short caption" + caption <- attr(x,"caption",exact = TRUE) + short.caption <- NULL + if (!is.null(caption) && length(caption) > 1){ + short.caption <- caption[2] + caption <- caption[1] + } + + ## Claudio Agostinelli 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 dated 2006-07-28 include.rownames, + ## include.colnames + pos <- 0 + if (include.rownames) pos <- 1 + + ## Claudio Agostinelli 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 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 { - add.to.row <- list(pos = list(), - command = vector(length = 0, mode = "character")) - npos <- 0 + stop("'add.to.row' argument must be a list of length 2") } - - ## Claudio Agostinelli dated 2006-07-28 add.to.row - ## Add further commands at the end of rows - if (type == "latex") { - ## Original code before changes in version 1.6-1 - ## PHEADER <- "\\hline\n" - - ## booktabs code from Matthieu Stigler , - ## 1 Feb 2012 - if(!booktabs){ - PHEADER <- "\\hline\n" - } else { - ## This code replaced to fix bug #2309, David Scott, 8 Jan 2014 - ## PHEADER <- ifelse(-1%in%hline.after, "\\toprule\n", "") - ## if(0%in%hline.after) { - ## PHEADER <- c(PHEADER, "\\midrule\n") - ## } - ## if(nrow(x)%in%hline.after) { - ## PHEADER <- c(PHEADER, "\\bottomrule\n") - ## } - if (is.null(hline.after)){ - PHEADER <- "" - } else { - hline.after <- sort(hline.after) - PHEADER <- rep("\\midrule\n", length(hline.after)) - if (hline.after[1] == -1) { - PHEADER[1] <- "\\toprule\n" - } - if (hline.after[length(hline.after)] == nrow(x)) { - PHEADER[length(hline.after)] <- "\\bottomrule\n" - } - } - } + } else { + add.to.row <- list(pos = list(), + command = vector(length = 0, mode = "character")) + npos <- 0 + } + + ## Claudio Agostinelli dated 2006-07-28 add.to.row + ## Add further commands at the end of rows + if (type == "latex") { + ## Original code before changes in version 1.6-1 + ## PHEADER <- "\\hline\n" + + ## booktabs code from Matthieu Stigler , + ## 1 Feb 2012 + if(!booktabs){ + PHEADER <- "\\hline\n" } else { + ## This code replaced to fix bug #2309, David Scott, 8 Jan 2014 + ## PHEADER <- ifelse(-1%in%hline.after, "\\toprule\n", "") + ## if(0%in%hline.after) { + ## PHEADER <- c(PHEADER, "\\midrule\n") + ## } + ## if(nrow(x)%in%hline.after) { + ## PHEADER <- c(PHEADER, "\\bottomrule\n") + ## } + if (is.null(hline.after)){ PHEADER <- "" - } - - lastcol <- rep(" ", nrow(x)+2) - if (!is.null(hline.after)) { - ## booktabs change - Matthieu Stigler: fill the hline arguments - ## separately, 1 Feb 2012 - ## - ## Code before booktabs change was: - ## add.to.row$pos[[npos+1]] <- hline.after - - if (!booktabs){ - add.to.row$pos[[npos+1]] <- hline.after - } else { - for(i in 1:length(hline.after)) { - add.to.row$pos[[npos+i]] <- hline.after[i] - } + } else { + hline.after <- sort(hline.after) + PHEADER <- rep("\\midrule\n", length(hline.after)) + if (hline.after[1] == -1) { + PHEADER[1] <- "\\toprule\n" } - 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 (hline.after[length(hline.after)] == nrow(x)) { + PHEADER[length(hline.after)] <- "\\bottomrule\n" } + } } - - 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\"}") - } - ## Disabling the check on known floating environments as many users - ## want to use additional environments. - # if (!all(!is.na(match(floating.environment, - # c("table","table*","sidewaystable", - # "margintable"))))) { - # stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}") - # } - if (("margintable" %in% floating.environment) - & (!is.null(table.placement))) { - warning("margintable does not allow for table placement; setting table.placement to NULL") - table.placement <- NULL + } else { + PHEADER <- "" + } + + lastcol <- rep(" ", nrow(x)+2) + if (!is.null(hline.after)) { + ## booktabs change - Matthieu Stigler: fill the hline arguments + ## separately, 1 Feb 2012 + ## + ## Code before booktabs change was: + ## add.to.row$pos[[npos+1]] <- hline.after + + if (!booktabs){ + add.to.row$pos[[npos+1]] <- hline.after + } else { + for(i in 1:length(hline.after)) { + add.to.row$pos[[npos+i]] <- hline.after[i] + } } - if (!is.null(table.placement) && - !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\",\"!\"}") + 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 (!all(!is.na(match(caption.placement, c("bottom","top"))))) { - stop("\"caption.placement\" must be either {\"bottom\",\"top\"}") + } + + 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\"}") + } + ## Disabling the check on known floating environments as many users + ## want to use additional environments. + ## if (!all(!is.na(match(floating.environment, + ## c("table","table*","sidewaystable", + ## "margintable"))))) { + ## stop("\"type\" must be in {\"table\", \"table*\", \"sidewaystable\", \"margintable\"}") + ## } + if (("margintable" %in% floating.environment) + & (!is.null(table.placement))) { + warning("margintable does not allow for table placement; setting table.placement to NULL") + table.placement <- NULL + } + if (!is.null(table.placement) && + !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 " dated 5-19-2003 + ## regarding "texfloat" + ## See e-mail form "Fernando Henrique Ferraz P. da Rosa" + ## " 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 (type == "latex") { - BCOMMENT <- "% " - ECOMMENT <- "\n" - ## See e-mail from "John S. Walker " dated 5-19-2003 - ## regarding "texfloat" - ## See e-mail form "Fernando Henrique Ferraz P. da Rosa" - ## " 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 " - ## dated 7-09-2003 regarding "suggestion for an amendment of - ## the source" - ## See e-mail from "Mitchell, David" - ## " dated 2003-07-09 regarding - ## "Additions to R xtable package" - ## See e-mail from "Garbade, Sven" - ## 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 <- "" - if ("center" %in% latex.environments){ - BENVIRONMENT <- paste(BENVIRONMENT, "\\centering\n", - sep = "") - } - for (i in 1:length(latex.environments)) { - if (latex.environments[i] == "") next - if (latex.environments[i] != "center"){ - 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 - } - ## Added "width" argument for use with "tabular*" or - ## "tabularx" environments - CR, 7/2/12 - if (is.null(width)){ - WIDTH <-"" - } else if (is.element(tabular.environment, - c("tabular", "longtable"))){ - 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.") - WIDTH <- "" - } else { - WIDTH <- paste("{", width, "}", sep = "") - } - - BTABULAR <- - paste("\\begin{", tabular.environment, "}", - WIDTH, "{", - 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") { - if (is.null(short.caption)){ - BCAPTION <- "\\caption{" - } else { - BCAPTION <- paste("\\caption[", short.caption, "]{", sep = "") - } - ECAPTION <- "} \\\\ \n" - if ((!is.null(caption)) && (type == "latex")) { - BTABULAR <- paste(BTABULAR, BCAPTION, caption, ECAPTION, - sep = "") - } - } - ## Claudio Agostinelli 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 = "") - - ## Add scalebox - CR, 7/2/12 - if (!is.null(scalebox)){ - BTABULAR <- paste("\\scalebox{", scalebox, "}{\n", BTABULAR, - sep = "") - ETABULAR <- paste(ETABULAR, "}\n", sep = "") - } - - ## BSIZE contributed by Benno 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" - ## Added caption width (jeff.laake@nooa.gov) - if(!is.null(caption.width)){ - BCAPTION <- paste("\\parbox{",caption.width,"}{",sep="") - ECAPTION <- "}" - } else { - BCAPTION <- NULL - ECAPTION <- NULL - } - if (is.null(short.caption)){ - BCAPTION <- paste(BCAPTION,"\\caption{",sep="") - } else { - BCAPTION <- paste(BCAPTION,"\\caption[", short.caption, "]{", sep="") - } - ECAPTION <- paste(ECAPTION,"} \n",sep="") - BROW <- "" - EROW <- " \\\\ \n" - BTH <- "" - ETH <- "" - STH <- " & " - BTD1 <- " & " - BTD2 <- "" - BTD3 <- "" - ETD <- "" - ## Based on contribution from Jonathan Swinton - ## 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 in e-mail - ## from 2008-08-20 suggested disabling this feature to avoid - ## problems with LaTeX's dcolumn package. - ## by Florian Wickelmaier - ## 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 <- "\n" - BTABLE <- paste("\n", sep = "") - ETABLE <- "
\n" + if ( floating == TRUE ) { + ## See e-mail from "Pfaff, Bernhard " + ## dated 7-09-2003 regarding "suggestion for an amendment of + ## the source" + ## See e-mail from "Mitchell, David" + ## " dated 2003-07-09 regarding + ## "Additions to R xtable package" + ## See e-mail from "Garbade, Sven" + ## 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 <- "" - BTABULAR <- "" - ETABULAR <- "" - BSIZE <- "" - ESIZE <- "" - BLABEL <- "\n" - BCAPTION <- paste(" ", - sep = "") - ECAPTION <- " \n" - BROW <- "" - EROW <- " \n" - BTH <- " " - ETH <- " " - STH <- " " - BTD1 <- " - ## 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 <- " " - sanitize <- function(str) { - result <- str - ## Changed as suggested in bug report #2795 - ## That is replacement of "&" is "&" - ## instead of previous "&" etc - ## 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) - ## Kurt Hornik on 2006/10/05 - ## recommended not escaping underscores. - ## result <- gsub("_", "\\_", result, fixed=TRUE) - return(result) - } - sanitize.numbers <- function(x) { - return(x) + } else { + BENVIRONMENT <- "" + EENVIRONMENT <- "" + if ("center" %in% latex.environments){ + BENVIRONMENT <- paste(BENVIRONMENT, "\\centering\n", + sep = "") } - sanitize.final <- function(result) { - ## Suggested by Uwe Ligges - ## 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) + for (i in 1:length(latex.environments)) { + if (latex.environments[i] == "") next + if (latex.environments[i] != "center"){ + 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 <- "" } - - result <- string("", file = file, append = append) - info <- R.Version() - ## modified Claudio Agostinelli dated 2006-07-28 - ## to set automatically the package version - if (comment){ - result <- result + BCOMMENT + type + " table generated in " + - info$language + " " + info$major + "." + info$minor + - " by xtable " + packageDescription('xtable')$Version + - " package" + ECOMMENT - if (!is.null(timestamp)){ - result <- result + BCOMMENT + timestamp + ECOMMENT - } + + 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 } - ## Claudio Agostinelli dated 2006-07-28 only.contents - if (!only.contents) { - result <- result + BTABLE - result <- result + BENVIRONMENT - if ( floating == TRUE ) { - if ((!is.null(caption)) && - (type == "html" ||caption.placement == "top")) { - result <- result + BCAPTION + caption + 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 + ## Added "width" argument for use with "tabular*" or + ## "tabularx" environments - CR, 7/2/12 + if (is.null(width)){ + WIDTH <-"" + } else if (is.element(tabular.environment, + c("tabular", "longtable"))){ + 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.") + WIDTH <- "" + } else { + WIDTH <- paste("{", width, "}", sep = "") + } + + BTABULAR <- + paste("\\begin{", tabular.environment, "}", + WIDTH, "{", + 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") { + if (is.null(short.caption)){ + BCAPTION <- "\\caption{" + } else { + BCAPTION <- paste("\\caption[", short.caption, "]{", sep = "") + } + ECAPTION <- "} \\\\ \n" + if ((!is.null(caption)) && (type == "latex")) { + BTABULAR <- paste(BTABULAR, BCAPTION, caption, ECAPTION, + sep = "") + } } ## Claudio Agostinelli dated 2006-07-28 - ## include.colnames, include.rownames - if (include.colnames) { - result <- result + BROW + BTH - if (include.rownames) { - result <- result + STH - } - ## David G. Whiting in e-mail 2007-10-09 - if (is.null(sanitize.colnames.function)) { - CNAMES <- sanitize(names(x)) - } else { - CNAMES <- sanitize.colnames.function(names(x)) - } - if (rotate.colnames) { - ##added by Markus Loecher, 2009-11-16 - CNAMES <- paste("\\begin{sideways}", CNAMES, "\\end{sideways}") - } - result <- result + paste(CNAMES, collapse = STH) - - result <- result + ETH + EROW + ## 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 = "") + + ## Add scalebox - CR, 7/2/12 + if (!is.null(scalebox)){ + BTABULAR <- paste("\\scalebox{", scalebox, "}{\n", BTABULAR, + sep = "") + ETABULAR <- paste(ETABULAR, "}\n", sep = "") } - - cols <- matrix("", nrow = nrow(x), ncol = ncol(x)+pos) + + ## BSIZE contributed by Benno 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" + ## Added caption width (jeff.laake@nooa.gov) + if(!is.null(caption.width)){ + BCAPTION <- paste("\\parbox{",caption.width,"}{",sep="") + ECAPTION <- "}" + } else { + BCAPTION <- NULL + ECAPTION <- NULL + } + if (is.null(short.caption)){ + BCAPTION <- paste(BCAPTION,"\\caption{",sep="") + } else { + BCAPTION <- paste(BCAPTION,"\\caption[", short.caption, "]{", sep="") + } + ECAPTION <- paste(ECAPTION,"} \n",sep="") + BROW <- "" + EROW <- " \\\\ \n" + BTH <- "" + ETH <- "" + STH <- " & " + BTD1 <- " & " + BTD2 <- "" + BTD3 <- "" + ETD <- "" + } else { + BCOMMENT <- "\n" + BTABLE <- paste("\n", sep = "") + ETABLE <- "
\n" + BENVIRONMENT <- "" + EENVIRONMENT <- "" + BTABULAR <- "" + ETABULAR <- "" + BSIZE <- "" + ESIZE <- "" + BLABEL <- "\n" + BCAPTION <- paste(" ", + sep = "") + ECAPTION <- " \n" + BROW <- "" + EROW <- " \n" + BTH <- " " + ETH <- " " + STH <- " " + BTD1 <- " + ## 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 <- " " + } + + result <- string("", file = file, append = append) + info <- R.Version() + ## modified Claudio Agostinelli dated 2006-07-28 + ## to set automatically the package version + if (comment){ + result <- result + BCOMMENT + type + " table generated in " + + info$language + " " + info$major + "." + info$minor + + " by xtable " + packageDescription('xtable')$Version + + " package" + ECOMMENT + if (!is.null(timestamp)){ + result <- result + BCOMMENT + timestamp + ECOMMENT + } + } + ## Claudio Agostinelli dated 2006-07-28 only.contents + if (!only.contents) { + result <- result + BTABLE + result <- result + BENVIRONMENT + if ( floating == TRUE ) { + if ((!is.null(caption)) && + (type == "html" ||caption.placement == "top")) { + result <- result + BCAPTION + caption + 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 dated 2006-07-28 + ## include.colnames, include.rownames + if (include.colnames) { + result <- result + BROW + BTH if (include.rownames) { - ## David G. Whiting in e-mail 2007-10-09 - if (is.null(sanitize.rownames.function)) { - RNAMES <- sanitize(row.names(x)) - } else { - RNAMES <- sanitize.rownames.function(row.names(x)) - } - if (rotate.rownames) { - ##added by Markus Loecher, 2009-11-16 - RNAMES <- paste("\\begin{sideways}", RNAMES, "\\end{sideways}") - } - cols[, 1] <- RNAMES + result <- result + STH } - -## Begin vectorizing the formatting code by Ian Fellows [ian@fellstat.com] -## 06 Dec 2011 -## -## disp <- function(y) { -## if (is.factor(y)) { -## y <- levels(y)[y] -## } -## if (is.list(y)) { -## y <- unlist(y) -## } -## return(y) -## } - varying.digits <- is.matrix( attr( x, "digits", exact = TRUE ) ) - ## Code for letting "digits" be a matrix was provided by - ## Arne Henningsen - ## in e-mail dated 2005-06-04. - ##if( !varying.digits ) { - ## modified Claudio Agostinelli 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)) { - xcol <- x[, i] - if(is.factor(xcol)) - xcol <- as.character(xcol) - if(is.list(xcol)) - xcol <- sapply(xcol, unlist) - ina <- is.na(xcol) - is.numeric.column <- is.numeric(xcol) - - if(is.character(xcol)) { - cols[, i+pos] <- xcol - } else { - if (is.null(format.args)){ - format.args <- list() - } - if (is.null(format.args$decimal.mark)){ - format.args$decimal.mark <- options()$OutDec - } - if(!varying.digits){ - curFormatArgs <- - c(list( - x = xcol, - format = - ifelse(attr(x, "digits", exact = TRUE )[i+1] < 0, "E", - attr(x, "display", exact = TRUE )[i+1]), - digits = abs(attr(x, "digits", exact = TRUE )[i+1])), - format.args) - cols[, i+pos] <- do.call("formatC", curFormatArgs) - }else{ - for( j in 1:nrow( cols ) ) { - curFormatArgs <- - c(list( - x = xcol[j], - 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])), - format.args) - cols[j, i+pos] <- do.call("formatC", curFormatArgs) - } - } - } - ## End Ian Fellows changes - - if ( any(ina) ) cols[ina, i+pos] <- NA.string - ## Based on contribution from Jonathan Swinton - ## 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]) - } - } + ## David G. Whiting in e-mail 2007-10-09 + if (is.null(sanitize.colnames.function)) { + CNAMES <- sanitize(names(x), type = type) + } else { + CNAMES <- sanitize.colnames.function(names(x)) } - - 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") { - ## booktabs change added the if() - 1 Feb 2012 - if(!booktabs) { - 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(caption)) && (type == "latex")) { - result <- result + BCAPTION + caption + ECAPTION - } - } - if (!is.null(attr(x, "label", exact = TRUE))) { - result <- result + BLABEL + attr(x, "label", exact = TRUE) + - ELABEL - } - ETABULAR <- "\\end{longtable}\n" + if (rotate.colnames) { + ##added by Markus Loecher, 2009-11-16 + CNAMES <- paste("\\begin{sideways}", CNAMES, "\\end{sideways}") + } + result <- result + paste(CNAMES, collapse = STH) + + result <- result + ETH + EROW + } + + cols <- matrix("", nrow = nrow(x), ncol = ncol(x)+pos) + if (include.rownames) { + ## David G. Whiting in e-mail 2007-10-09 + if (is.null(sanitize.rownames.function)) { + RNAMES <- sanitize(row.names(x), type = type) + } else { + RNAMES <- sanitize.rownames.function(row.names(x)) + } + if (rotate.rownames) { + ##added by Markus Loecher, 2009-11-16 + RNAMES <- paste("\\begin{sideways}", RNAMES, "\\end{sideways}") + } + cols[, 1] <- RNAMES + } + + ## Begin vectorizing the formatting code by Ian Fellows [ian@fellstat.com] + ## 06 Dec 2011 + ## + ## disp <- function(y) { + ## if (is.factor(y)) { + ## y <- levels(y)[y] + ## } + ## if (is.list(y)) { + ## y <- unlist(y) + ## } + ## return(y) + ## } + varying.digits <- is.matrix( attr( x, "digits", exact = TRUE ) ) + ## Code for letting "digits" be a matrix was provided by + ## Arne Henningsen + ## in e-mail dated 2005-06-04. + ##if( !varying.digits ) { + ## modified Claudio Agostinelli 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)) { + xcol <- x[, i] + if(is.factor(xcol)) + xcol <- as.character(xcol) + if(is.list(xcol)) + xcol <- sapply(xcol, unlist) + ina <- is.na(xcol) + is.numeric.column <- is.numeric(xcol) + + if(is.character(xcol)) { + cols[, i+pos] <- xcol + } else { + if (is.null(format.args)){ + format.args <- list() + } + if (is.null(format.args$decimal.mark)){ + format.args$decimal.mark <- options()$OutDec + } + if(!varying.digits){ + curFormatArgs <- + c(list( + x = xcol, + format = + ifelse(attr(x, "digits", exact = TRUE )[i+1] < 0, "E", + attr(x, "display", exact = TRUE )[i+1]), + digits = abs(attr(x, "digits", exact = TRUE )[i+1])), + format.args) + cols[, i+pos] <- do.call("formatC", curFormatArgs) + }else{ + for( j in 1:nrow( cols ) ) { + curFormatArgs <- + c(list( + x = xcol[j], + 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])), + format.args) + cols[j, i+pos] <- do.call("formatC", curFormatArgs) } - result <- result + ETABULAR - result <- result + ESIZE - if ( floating == TRUE ) { - if ((!is.null(caption)) && - (type == "latex" && caption.placement == "bottom")) { - result <- result + BCAPTION + caption + ECAPTION - } - if (!is.null(attr(x, "label", exact = TRUE)) && - caption.placement == "bottom") { - result <- result + BLABEL + attr(x, "label", exact = TRUE) + - ELABEL - } + } + } + ## End Ian Fellows changes + + if ( any(ina) ) cols[ina, i+pos] <- NA.string + ## Based on contribution from Jonathan Swinton + ## in e-mail dated Wednesday, January 17, 2007 + if ( is.numeric.column ) { + cols[, i+pos] <- + sanitize.numbers(cols[, i+pos], type = type, + math.style.negative = math.style.negative) + } else { + if (is.null(sanitize.text.function)) { + cols[, i+pos] <- sanitize(cols[, i+pos], type = type) + } 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") { + ## booktabs change added the if() - 1 Feb 2012 + if(!booktabs) { + 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(caption)) && (type == "latex")) { + result <- result + BCAPTION + caption + ECAPTION } - result <- result + EENVIRONMENT - result <- result + ETABLE + } + if (!is.null(attr(x, "label", exact = TRUE))) { + result <- result + BLABEL + attr(x, "label", exact = TRUE) + + ELABEL + } + ETABULAR <- "\\end{longtable}\n" } - result <- sanitize.final(result) - - if (print.results){ - print(result) + result <- result + ETABULAR + result <- result + ESIZE + if ( floating == TRUE ) { + if ((!is.null(caption)) && + (type == "latex" && caption.placement == "bottom")) { + result <- result + BCAPTION + caption + ECAPTION + } + if (!is.null(attr(x, "label", exact = TRUE)) && + caption.placement == "bottom") { + result <- result + BLABEL + attr(x, "label", exact = TRUE) + + ELABEL + } } - - return(invisible(result$text)) + result <- result + EENVIRONMENT + result <- result + ETABLE + } + result <- sanitize.final(result, type = type) + + if (print.results){ + print(result) + } + + return(invisible(result$text)) } "+.string" <- function(x, y) { - x$text <- paste(x$text, as.string(y)$text, sep = "") - return(x) + 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()) + 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) + 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 coerce argument to a string")) - if (class(x) == "string") - return(x) - stop("Cannot coerce argument to a string") + 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 coerce argument to a string")) + if (class(x) == "string") + return(x) + stop("Cannot coerce argument to a string") } is.string <- function(x) { - return(class(x) == "string") + return(class(x) == "string") } diff --git a/pkg/R/sanitize.R b/pkg/R/sanitize.R new file mode 100644 index 0000000..92441fd --- /dev/null +++ b/pkg/R/sanitize.R @@ -0,0 +1,53 @@ +sanitize <- function(str, type) { + if(type == "latex"){ + 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) + } else { + result <- str + result <- gsub("&", "&", result, fixed = TRUE) + result <- gsub(">", ">", result, fixed = TRUE) + result <- gsub("<", "<", result, fixed = TRUE) + return(result) + } +} + + +sanitize.numbers <- function(x, type, math.style.negative){ + if (type == "latex"){ + result <- x + if ( math.style.negative ) { + for(i in 1:length(x)) { + result[i] <- gsub("-", "$-$", result[i], fixed = TRUE) + } + } + return(result) + } else { + return(x) + } +} + + +sanitize.final <- function(result, type){ + if (type == "latex"){ + return(result) + } else { + result$text <- gsub(" *", " ", result$text, fixed = TRUE) + result$text <- gsub(' align="left"', "", result$text, + fixed = TRUE) + return(result) + } +} diff --git a/pkg/R/xtableList.R b/pkg/R/xtableList.R index f0fb6d6..d49700c 100644 --- a/pkg/R/xtableList.R +++ b/pkg/R/xtableList.R @@ -1,6 +1,6 @@ ### Function to create lists of tables xtableList <- function(x, caption = NULL, label = NULL, align = NULL, - digits = NULL, display = NULL, ...) { + digits = NULL, display = NULL, ...) { if (is.null(digits)){ digitsList <- vector("list", length(x)) } else { @@ -69,125 +69,131 @@ print.xtableList <- function(x, ...) { ## Get number of rows for each table in list of tables - if (booktabs){ - tRule <- "\\toprule" - mRule <- "\\midrule" - bRule <- "\\bottomrule" - } else { - tRule <- "\\hline" - mRule <- "\\hline" - bRule <- "\\hline" - } nCols <- dim(x[[1]])[2] rowNums <- sapply(x, dim)[1,] combinedRowNums <- cumsum(rowNums) combined <- do.call(rbind, x) - if (colnames.format == "single"){ - add.to.row <- list(pos = NULL, command = NULL) - add.to.row$pos <- as.list(c(0, combinedRowNums[-length(x)], - dim(combined)[1])) - command <- sapply(x, attr, "subheading") - - add.to.row$command[1:length(x)] <- - paste0(mRule,"\n\\multicolumn{", nCols, "}{l}{", command, "}\\\\\n") - if ( (booktabs) & length(attr(x, "message") > 0) ){ - attr(x, "message")[1] <- - paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1]) - } - add.to.row$command[length(x) + 1] <- - paste0("\n\\multicolumn{", nCols, "}{l}{", attr(x, "message"), "}\\\\\n", - collapse = "") - add.to.row$command[length(x) + 1] <- - paste0(bRule, add.to.row$command[length(x) + 1]) - - class(combined) <- c("xtableList", "data.frame") - hline.after <- c(-1) - include.colnames <- TRUE - } - - ## Create headings for columns if multiple headings are needed - if (colnames.format == "multiple"){ - if (is.null(sanitize.colnames.function)) { - colHead <- names(x[[1]]) + if (type == "latex"){ + ## Special treatment if using booktabs + if (booktabs){ + tRule <- "\\toprule" + mRule <- "\\midrule" + bRule <- "\\bottomrule" } else { - colHead <- sanitize.colnames.function(names(x[[1]])) + tRule <- "\\hline" + mRule <- "\\hline" + bRule <- "\\hline" } - if (rotate.colnames) { - colHead <- paste("\\begin{sideways}", colHead, "\\end{sideways}") + if (colnames.format == "single"){ + add.to.row <- list(pos = NULL, command = NULL) + add.to.row$pos <- as.list(c(0, combinedRowNums[-length(x)], + dim(combined)[1])) + command <- sapply(x, attr, "subheading") + + add.to.row$command[1:length(x)] <- + paste0(mRule,"\n\\multicolumn{", nCols, "}{l}{", command, "}\\\\\n") + if ( (booktabs) & length(attr(x, "message") > 0) ){ + attr(x, "message")[1] <- + paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1]) + } + add.to.row$command[length(x) + 1] <- + paste0("\n\\multicolumn{", nCols, "}{l}{", + attr(x, "message"), "}\\\\\n", + collapse = "") + add.to.row$command[length(x) + 1] <- + paste0(bRule, add.to.row$command[length(x) + 1]) + + class(combined) <- c("xtableList", "data.frame") + hline.after <- c(-1) + include.colnames <- TRUE } - colHead <- paste0(colHead, collapse = " & ") - if (include.rownames) { - colHead <- paste0(" & ", colHead) - } - colHead <- paste0(tRule, "\n", colHead, " \\\\", mRule, "\n") - add.to.row <- list(pos = NULL, command = NULL) - add.to.row$pos <- as.list(c(0, c(combinedRowNums[1:length(x)]))) - command <- sapply(x, attr, "subheading") - add.to.row$command[1] <- - paste0("\n\\multicolumn{", nCols, "}{l}{", command[1], "}", " \\\\ \n", - colHead) - add.to.row$command[2:length(x)] <- - paste0(bRule, - "\\\\ \n\\multicolumn{", nCols, "}{l}{", - command[2:length(x)], "}", - "\\\\ \n", - colHead) - if ( (booktabs) & length(attr(x, "message") > 0) ){ - attr(x, "message")[1] <- - paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1]) - } - add.to.row$command[length(x) + 1] <- - paste0("\n\\multicolumn{", nCols, "}{l}{", attr(x, "message"), "}\\\\\n", - collapse = "") - add.to.row$command[length(x) + 1] <- - paste0(bRule, add.to.row$command[length(x) + 1]) - class(combined) <- c("xtableList", "data.frame") - hline.after <- NULL - - include.colnames <- FALSE + ## Create headings for columns if multiple headings are needed + if (colnames.format == "multiple"){ + if (is.null(sanitize.colnames.function)) { + colHead <- names(x[[1]]) + } else { + colHead <- sanitize.colnames.function(names(x[[1]])) + } + if (rotate.colnames) { + colHead <- paste("\\begin{sideways}", colHead, "\\end{sideways}") + } + colHead <- paste0(colHead, collapse = " & ") + if (include.rownames) { + colHead <- paste0(" & ", colHead) + } + colHead <- paste0(tRule, "\n", colHead, " \\\\", mRule, "\n") + add.to.row <- list(pos = NULL, command = NULL) + add.to.row$pos <- as.list(c(0, c(combinedRowNums[1:length(x)]))) + command <- sapply(x, attr, "subheading") + add.to.row$command[1] <- + paste0("\n\\multicolumn{", nCols, "}{l}{", command[1], "}", " \\\\ \n", + colHead) + add.to.row$command[2:length(x)] <- + paste0(bRule, + "\\\\ \n\\multicolumn{", nCols, "}{l}{", + command[2:length(x)], "}", + "\\\\ \n", + colHead) + if ( (booktabs) & length(attr(x, "message") > 0) ){ + attr(x, "message")[1] <- + paste0("\\rule{0em}{2.5ex}", attr(x, "message")[1]) + } + add.to.row$command[length(x) + 1] <- + paste0("\n\\multicolumn{", nCols, "}{l}{", + attr(x, "message"), "}\\\\\n", + collapse = "") + add.to.row$command[length(x) + 1] <- + paste0(bRule, add.to.row$command[length(x) + 1]) + + class(combined) <- c("xtableList", "data.frame") + hline.after <- NULL + + include.colnames <- FALSE + } + + print.xtable(combined, + type = type, + floating = floating, + floating.environment = floating.environment, + table.placement = table.placement, + caption.placement = caption.placement, + caption.width = caption.width, + latex.environments = latex.environments, + tabular.environment = tabular.environment, + size = size, + hline.after = hline.after, + NA.string = NA.string, + include.rownames = include.rownames, + include.colnames = include.colnames, + only.contents = only.contents, + add.to.row = add.to.row, + sanitize.text.function = sanitize.text.function, + sanitize.rownames.function = sanitize.rownames.function, + sanitize.colnames.function = sanitize.colnames.function, + math.style.negative = math.style.negative, + html.table.attributes = html.table.attributes, + print.results = print.results, + format.args = format.args, + rotate.rownames = rotate.rownames, + rotate.colnames = rotate.colnames, + booktabs = booktabs, + scalebox = scalebox, + width = width, + comment = comment, + timestamp = timestamp, + ...) + } else { + stop("print.xtableList not yet implemented for this type") } - - print.xtable(combined, - type = type, - floating = floating, - floating.environment = floating.environment, - table.placement = table.placement, - caption.placement = caption.placement, - caption.width = caption.width, - latex.environments = latex.environments, - tabular.environment = tabular.environment, - size = size, - hline.after = hline.after, - NA.string = NA.string, - include.rownames = include.rownames, - include.colnames = include.colnames, - only.contents = only.contents, - add.to.row = add.to.row, - sanitize.text.function = sanitize.text.function, - sanitize.rownames.function = sanitize.rownames.function, - sanitize.colnames.function = sanitize.colnames.function, - math.style.negative = math.style.negative, - html.table.attributes = html.table.attributes, - print.results = print.results, - format.args = format.args, - rotate.rownames = rotate.rownames, - rotate.colnames = rotate.colnames, - booktabs = booktabs, - scalebox = scalebox, - width = width, - comment = comment, - timestamp = timestamp, - ...) - } ### Uses xtableList xtableLSMeans <- function(x, caption = NULL, label = NULL, - align = NULL, digits = NULL, - display = NULL, auto = FALSE, - ...){ + align = NULL, digits = NULL, + display = NULL, auto = FALSE, + ...){ if (attr(x, "estName") == "lsmean"){ xList <- split(x, f = x[, 2]) for (i in 1:length(xList)){ @@ -202,8 +208,8 @@ xtableLSMeans <- function(x, caption = NULL, label = NULL, } else { xList <- x xList <- xtable.data.frame(xList, caption = caption, label = label, - align = align, digits = digits, - display = display, auto = auto, ...) + align = align, digits = digits, + display = display, auto = auto, ...) } return(xList) } diff --git a/pkg/man/xtable-internal.Rd b/pkg/man/xtable-internal.Rd index 1e0bd4d..00df62f 100644 --- a/pkg/man/xtable-internal.Rd +++ b/pkg/man/xtable-internal.Rd @@ -3,6 +3,9 @@ \alias{xtableList} \alias{print.xtableList} \alias{xtableLSMeans} +\alias{sanitize} +\alias{sanitize.numbers} +\alias{sanitize.final} \title{Internal xtable Functions} \description{