From 8041ac2e7fed618e974b4c6a44e68d9626c091d2 Mon Sep 17 00:00:00 2001 From: Duncan Murdoch Date: Mon, 11 Nov 2024 15:06:36 -0500 Subject: [PATCH 1/5] reformat --- R/html.tabular.R | 173 +++-- R/options.R | 142 ++-- R/tabular.R | 1736 +++++++++++++++++++++++++--------------------- 3 files changed, 1125 insertions(+), 926 deletions(-) diff --git a/R/html.tabular.R b/R/html.tabular.R index f9cf233..3e6419b 100644 --- a/R/html.tabular.R +++ b/R/html.tabular.R @@ -1,75 +1,95 @@ -htmlify <- function (x) # Taken from the tools package + +htmlify <- function (x) + # Taken from the tools package { - fsub <- function(pattern, replacement, x) - gsub(pattern, replacement, x, fixed=TRUE, useBytes=TRUE) - - x <- fsub("&", "&", x) - x <- fsub("---", "—", x) - x <- fsub("--", "–", x) - x <- fsub("``", "“", x) - x <- fsub("''", "”", x) - x <- gsub("`([^']+)'", "‘\\1’", x, perl=TRUE, useBytes=TRUE) - x <- fsub("`", "'", x) - x <- fsub("<", "<", x) - x <- fsub(">", ">", x) - x <- fsub("\"\\{\"", "\"{\"", x) - x <- fsub("\"", """, x) - x + fsub <- function(pattern, replacement, x) + gsub(pattern, + replacement, + x, + fixed = TRUE, + useBytes = TRUE) + + x <- fsub("&", "&", x) + x <- fsub("---", "—", x) + x <- fsub("--", "–", x) + x <- fsub("``", "“", x) + x <- fsub("''", "”", x) + x <- gsub("`([^']+)'", + "‘\\1’", + x, + perl = TRUE, + useBytes = TRUE) + x <- fsub("`", "'", x) + x <- fsub("<", "<", x) + x <- fsub(">", ">", x) + x <- fsub("\"\\{\"", "\"{\"", x) + x <- fsub("\"", """, x) + x } -htmlNumeric <- function(chars, minus=TRUE, leftpad=TRUE, rightpad=TRUE) { - regexp <- "^( *)([-]?)([^ -][^ ]*)( *)$" - leadin <- sub(regexp, "\\1", chars) - sign <- sub(regexp, "\\2", chars) - rest <- sub(regexp, "\\3", chars) - tail <- sub(regexp, "\\4", chars) - - figurespace <- " " - minussign <- "−" - - if (minus && any(neg <- sign == "-")) { - if (any(leadin[!neg] == "")) - leadin <- sub("^", " ", leadin) - leadin[!neg] <- sub(" ", "", leadin[!neg]) - sign[!neg] <- figurespace - sign[neg] <- minussign - } - if (leftpad && any(ind <- leadin != "")) - leadin[ind] <- gsub(" ", figurespace, leadin[ind]) - - if (rightpad && any(ind <- tail != "")) - tail[ind] <- gsub(" ", figurespace, tail[ind]) - - paste(leadin, sign, rest, tail, sep="") +htmlNumeric <- function(chars, + minus = TRUE, + leftpad = TRUE, + rightpad = TRUE) { + regexp <- "^( *)([-]?)([^ -][^ ]*)( *)$" + leadin <- sub(regexp, "\\1", chars) + sign <- sub(regexp, "\\2", chars) + rest <- sub(regexp, "\\3", chars) + tail <- sub(regexp, "\\4", chars) + + figurespace <- " " + minussign <- "−" + + if (minus && any(neg <- sign == "-")) { + if (any(leadin[!neg] == "")) + leadin <- sub("^", " ", leadin) + leadin[!neg] <- sub(" ", "", leadin[!neg]) + sign[!neg] <- figurespace + sign[neg] <- minussign + } + if (leftpad && any(ind <- leadin != "")) + leadin[ind] <- gsub(" ", figurespace, leadin[ind]) + + if (rightpad && any(ind <- tail != "")) + tail[ind] <- gsub(" ", figurespace, tail[ind]) + + paste(leadin, sign, rest, tail, sep = "") } -CSSclassname <- function(just) - ifelse(just == "l", "left", - ifelse(just == "c", "center", - ifelse(just == "r", "right", just))) - -toHTML <- function(object, file = "", - options = NULL, id = NULL, - append = FALSE, - browsable = TRUE, ...) { +CSSclassname <- function(just) + ifelse(just == "l", "left", ifelse(just == "c", "center", ifelse(just == "r", "right", just))) +toHTML <- function(object, + file = "", + options = NULL, + id = NULL, + append = FALSE, + browsable = TRUE, + escape = opts$escape, + ...) { if (!is.null(options)) { saveopts <- do.call(table_options, options) - on.exit(table_options(saveopts), add=TRUE) + on.exit(table_options(saveopts), add = TRUE) } opts <- table_options() output <- character() - mycat <- function(...) output <<- c(output, unlist(list(...))) + mycat <- function(...) + output <<- c(output, unlist(list(...))) defjust <- opts$justification blankhead <- "  \n" - classes <- chars <- format(object, html = TRUE, minus = opts$HTMLminus, - leftpad = opts$HTMLleftpad, - rightpad = opts$HTMLrightpad, ...) # format without justification + classes <- chars <- format( + object, + html = TRUE, + minus = opts$HTMLminus, + leftpad = opts$HTMLleftpad, + rightpad = opts$HTMLrightpad, + ... + ) # format without justification classes[] <- "" vjust <- attr(object, "justification") @@ -87,10 +107,10 @@ toHTML <- function(object, file = "", rjust[is.na(rjust)] <- opts$rowlabeljustification ind <- rjust != defjust rowClasses[ind] <- sprintf(' class="%s"', CSSclassname(rjust[ind])) - rowLabels[] <- sprintf( " %s\n", rowClasses, rowLabels) + rowLabels[] <- sprintf(" %s\n", rowClasses, rowLabels) colnamejust <- attr(rowLabels, "colnamejust") - colnamejust <- rep(colnamejust, length.out=nleading) + colnamejust <- rep(colnamejust, length.out = nleading) colnameClasses <- colnames(rowLabels) colnameClasses[] <- "" ind <- is.na(colnamejust) @@ -107,29 +127,34 @@ toHTML <- function(object, file = "", multi <- matrix(0, nrow(clabels), ncol(clabels)) prevmulti <- rep(0, nrow(multi)) for (i in rev(seq_len(ncol(multi)))) { - ind <- is.na(clabels[,i]) + ind <- is.na(clabels[, i]) multi[!ind, i] <- 1 + prevmulti[!ind] prevmulti[ind] <- 1 + prevmulti[ind] prevmulti[!ind] <- 0 } colspan <- ifelse(multi < 2, "", sprintf(' colspan="%d"', multi)) - class <- ifelse(cjust == defjust | multi == 0, "", sprintf(' class="%s"', CSSclassname(cjust))) + class <- ifelse(cjust == defjust | + multi == 0, + "", + sprintf(' class="%s"', CSSclassname(cjust))) clabels[clabels == ""] <- " " - clabels <- ifelse(multi == 0, "", sprintf(' %s\n', colspan, class, clabels)) + clabels <- ifelse(multi == 0, + "", + sprintf(' %s\n', colspan, class, clabels)) rowLabelHeadings <- matrix(blankhead, nrow(clabels), ncol(rowLabels)) - rowLabelHeadings[nrow(clabels),] <- colnames(rowLabels) + rowLabelHeadings[nrow(clabels), ] <- colnames(rowLabels) if (opts$doHTMLheader) { - head <- sub("CHARSET", localeToCharset(), opts$HTMLhead, fixed=TRUE) + head <- sub("CHARSET", localeToCharset(), opts$HTMLhead, fixed = TRUE) mycat(head) } if (opts$doCSS) { - if (is.null(id)) - css <- gsub("#ID ", "", opts$CSS, fixed=TRUE) + if (is.null(id)) + css <- gsub("#ID ", "", opts$CSS, fixed = TRUE) else - css <- gsub("#ID", paste0("#", id), opts$CSS, fixed=TRUE) + css <- gsub("#ID", paste0("#", id), opts$CSS, fixed = TRUE) mycat(css) } @@ -137,7 +162,7 @@ toHTML <- function(object, file = "", mycat(opts$HTMLbody) if (opts$doBegin) { - if (is.null(id)) + if (is.null(id)) id <- "" else id <- sprintf(' id="%s"', id) @@ -147,7 +172,7 @@ toHTML <- function(object, file = "", mycat(sprintf('%s\n', opts$HTMLcaption)) if (opts$doHeader) { - rows <- apply(cbind(rowLabelHeadings, clabels), 1, paste0, collapse="") + rows <- apply(cbind(rowLabelHeadings, clabels), 1, paste0, collapse = "") mycat('\n') mycat(sprintf('\n%s\n', CSSclassname(defjust), rows)) mycat('\n') @@ -158,7 +183,7 @@ toHTML <- function(object, file = "", mycat('\n') } if (opts$doBody) { - rows <- apply(cbind(rowLabels, chars), 1, paste0, collapse="") + rows <- apply(cbind(rowLabels, chars), 1, paste0, collapse = "") mycat('\n') mycat(sprintf('\n%s\n', CSSclassname(defjust), rows)) mycat('\n') @@ -169,7 +194,10 @@ toHTML <- function(object, file = "", result <- browsable(HTML(output), value = browsable) if (!identical(file, "")) { if (is.character(file)) { - file <- file(file, open = if (append) "at" else "wt") + file <- file(file, open = if (append) + "at" + else + "wt") on.exit(close(file)) } writeLines(output, file) @@ -179,14 +207,13 @@ toHTML <- function(object, file = "", } html.tabular <- function(object, ...) { - toHTML(object, ...) + toHTML(object, ...) } writeCSS <- function(CSS = htmloptions()$CSS, id = NULL) { - if (is.null(id)) - css <- gsub("#ID ", "", CSS, fixed=TRUE) + if (is.null(id)) + css <- gsub("#ID ", "", CSS, fixed = TRUE) else - css <- gsub("#ID", paste0("#", id), CSS, fixed=TRUE) + css <- gsub("#ID", paste0("#", id), CSS, fixed = TRUE) cat(css) } - diff --git a/R/options.R b/R/options.R index 6ae7f59..2071d6a 100644 --- a/R/options.R +++ b/R/options.R @@ -11,7 +11,7 @@ CSSdefault <- '\n" +[1] "\n" $HTMLhead [1] "\n\n\n\n" @@ -164,6 +164,9 @@ $HTMLrightpad $HTMLminus [1] FALSE +$escape +[1] FALSE + > table_options()[c("toprule", "midrule", "bottomrule", + "titlerule")] @@ -780,7 +783,6 @@ $i$ & Sepal.Length & Sepal.Width & Petal.Length & Petal.Width & \multicolumn{1} > options(tables.texify = TRUE) > toLatex(tabular(mean ~ Factor(A) * All(df), data = df)) -Loading required namespace: Hmisc \begin{tabular}{lcc} \toprule & \multicolumn{2}{c}{A} \\ \cmidrule(lr){2-3} @@ -983,4 +985,4 @@ All & $150$ & $5.84$ & $0.83$ & $3.06$ & $0.44$ \\ *** Run successfully completed *** > proc.time() user system elapsed - 0.688 0.030 0.718 + 0.561 0.024 0.584 From 1c369943082507fbdcb3b4db215136d5f9fec945 Mon Sep 17 00:00:00 2001 From: Duncan Murdoch Date: Wed, 22 Jan 2025 11:29:09 -0500 Subject: [PATCH 4/5] Add news and change version --- DESCRIPTION | 2 +- NEWS.md | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index aabaa02..d17e341 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: tables Title: Formula-Driven Table Generation -Version: 0.9.31 +Version: 0.9.33 Authors@R: person(given = "Duncan", family = "Murdoch", role = c("aut", "cre"), diff --git a/NEWS.md b/NEWS.md index 2b4f0a3..697f08d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,12 @@ +# tables 0.9.33 + +- The fix for issue #30 was incomplete for some reason. +- `table_options()` now returns the value of options if called +with a character argument. +- An option `escape` has been added to `table_options()`. If `TRUE`, +any special characters in HTML or LaTeX output are escaped so they +appear as-is. + # tables 0.9.31 - In a few places `len` was used instead of `length.out` in calls to From e7ef2e68aea1c1a0a145a50eb8c39ca60713650c Mon Sep 17 00:00:00 2001 From: Duncan Murdoch Date: Wed, 22 Jan 2025 13:03:15 -0500 Subject: [PATCH 5/5] More details. --- R/latex.tabular.R | 2 +- R/toKable.R | 6 +++--- man/toKable.Rd | 6 +----- 3 files changed, 5 insertions(+), 9 deletions(-) diff --git a/R/latex.tabular.R b/R/latex.tabular.R index 68b8a9a..202afec 100644 --- a/R/latex.tabular.R +++ b/R/latex.tabular.R @@ -30,7 +30,7 @@ toLatex.tabular <- function(object, file = "", options = NULL, chars <- format(object, latex = TRUE, minus = opts$latexminus, leftpad = opts$latexleftpad, rightpad = opts$latexrightpad, - escape = escape, ...) # format without justification + ...) # format without justification vjust <- attr(object, "justification") vjustdefs <- rep(opts$justification, length.out=ncol(object)) diff --git a/R/toKable.R b/R/toKable.R index 083b08c..4047e0d 100644 --- a/R/toKable.R +++ b/R/toKable.R @@ -9,7 +9,7 @@ getKnitrFormat <- function(default = "latex") { result } -toKable <- function(table, format = getKnitrFormat(), booktabs = TRUE, escape = TRUE, ...) +toKable <- function(table, format = getKnitrFormat(), booktabs = TRUE, ...) { if (!inherits(table, "tabular")) stop("'table' must be a 'tabular' object.") @@ -21,10 +21,10 @@ toKable <- function(table, format = getKnitrFormat(), booktabs = TRUE, escape = if (format == "latex") { save <- if (booktabs) booktabs() else table_options() - lines <- paste(toLatex(table, escape = escape)$text, collapse = "") + lines <- paste(toLatex(table)$text, collapse = "") table_options(save) } else { - lines <- toHTML(table, escape = escape) + lines <- toHTML(table) } structure(lines, format = format, class = "knitr_kable", diff --git a/man/toKable.Rd b/man/toKable.Rd index ebb3d46..2179404 100644 --- a/man/toKable.Rd +++ b/man/toKable.Rd @@ -11,8 +11,7 @@ functions to a format consistent with the output of the customized using the \pkg{kableExtra} package. } \usage{ -toKable(table, format = getKnitrFormat(), booktabs = TRUE, - escape = TRUE, ...) +toKable(table, format = getKnitrFormat(), booktabs = TRUE, ...) getKnitrFormat(default = "latex") } \arguments{ @@ -27,9 +26,6 @@ only \code{"latex"} and \code{"html"} are supported. Should the table be rendered in \code{\link{booktabs}} style? This only affects LaTeX output. } - \item{escape}{ -Should special characters be escaped? - } \item{...}{ Additional arguments to pass to \code{\link{html.tabular}} or \code{\link{latex.tabular}}. }