Add escape to table_options()

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: tables
 Title: Formula-Driven Table Generation
-Version: 0.9.32
+Version: 0.9.33
 Authors@R: person(given = "Duncan",
                   family = "Murdoch",
                   role = c("aut", "cre"),

NEWS.md

@@ -1,6 +1,12 @@
-# tables 0.9.32
+
+# 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
 

R/All.R

@@ -9,7 +9,7 @@ All <- function(df,
            texify = getOption("tables.texify", FALSE)) {
     names <- colnames(df)
     if (texify)
-      names <- Hmisc::latexTranslate(names)
+      names <- texify(names)
 
     f <- NULL
     for (i in seq_along(names)) {

R/escapes.R

@@ -0,0 +1,37 @@
+texify <- function(x) {
+  # Based on knitr function
+  x <- gsub("\\\\", "\\\\textbackslash", x)
+  x <- gsub("([#$%&_{}])", "\\\\\\1", x)
+  x <- gsub("\\\\textbackslash", "\\\\textbackslash{}", x)
+  x <- gsub("~", "\\\\textasciitilde{}", x)
+  x <- gsub("\\^", "\\\\textasciicircum{}", x)
+  x
+}
+
+htmlify <- function (x)
+  # Taken from the tools package
+{
+  fsub <- function(pattern, replacement, x)
+    gsub(pattern,
+         replacement,
+         x,
+         fixed = TRUE,
+         useBytes = TRUE)
+
+  x <- fsub("&", "&amp;", x)
+  x <- fsub("---", "&mdash;", x)
+  x <- fsub("--", "&ndash;", x)
+  x <- fsub("``", "&ldquo;", x)
+  x <- fsub("''", "&rdquo;", x)
+  x <- gsub("`([^']+)'",
+            "&lsquo;\\1&rsquo;",
+            x,
+            perl = TRUE,
+            useBytes = TRUE)
+  x <- fsub("`", "'", x)
+  x <- fsub("<", "&lt;", x)
+  x <- fsub(">", "&gt;", x)
+  x <- fsub("\"\\{\"", "\"{\"", x)
+  x <- fsub("\"", "&quot;", x)
+  x
+}

R/html.tabular.R

@@ -1,75 +1,74 @@
 
-htmlify <- function (x) # Taken from the tools package
-{
-    fsub <- function(pattern, replacement, x) 
-       gsub(pattern, replacement, x, fixed=TRUE, useBytes=TRUE)
-
-    x <- fsub("&", "&amp;", x)
-    x <- fsub("---", "&mdash;", x)
-    x <- fsub("--", "&ndash;", x)
-    x <- fsub("``", "&ldquo;", x)
-    x <- fsub("''", "&rdquo;", x)
-    x <- gsub("`([^']+)'", "&lsquo;\\1&rsquo;", x, perl=TRUE, useBytes=TRUE)
-    x <- fsub("`", "'", x)
-    x <- fsub("<", "&lt;", x)
-    x <- fsub(">", "&gt;", x)
-    x <- fsub("\"\\{\"", "\"{\"", x)
-    x <- fsub("\"", "&quot;", 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 <- "&#x2007;"
-    minussign <- "&minus;"
-
-    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 <- "&#x2007;"
+  minussign <- "&minus;"
+
+  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,
+                   ...) {
   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(...)))
+
+  escape <- opts$escape
+
+  do_escape <- function(x) {
+    if (escape) 
+      x <- htmlify(x)
+    x
+  }
 
   defjust <- opts$justification
   blankhead <- "  <th>&nbsp;</th>\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,
+    escape = escape,
+    ...
+  ) # format without justification
   classes[] <- ""
 
   vjust <- attr(object, "justification")
@@ -79,65 +78,70 @@ toHTML <- function(object, file = "",
   chars[chars == ""] <- "&nbsp;"
   chars[] <- sprintf("  <td%s>%s</td>\n", classes, chars)
 
-  rowClasses <- rowLabels <- attr(object, "rowLabels")
+  rowClasses <- rowLabels <- do_escape(attr(object, "rowLabels"))
   rowClasses[] <- ""
   nleading <- ncol(rowLabels)
   rowLabels[is.na(rowLabels)] <- "&nbsp;"
   rjust <- attr(rowLabels, "justification")
   rjust[is.na(rjust)] <- opts$rowlabeljustification
   ind <- rjust != defjust
   rowClasses[ind] <- sprintf(' class="%s"', CSSclassname(rjust[ind]))
-  rowLabels[] <- sprintf( "  <th%s>%s</th>\n", rowClasses, rowLabels)
+  rowLabels[] <- sprintf("  <th%s>%s</th>\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)
   colnamejust[ind] <- defjust
   ind <- colnamejust != defjust
   colnameClasses[ind] <- sprintf(' class="%s"', CSSclassname(colnamejust[ind]))
-  colnames(rowLabels) <- sprintf("  <th%s>%s</th>\n", colnameClasses, colnames(rowLabels))
+  colnames(rowLabels) <- sprintf("  <th%s>%s</th>\n", colnameClasses, do_escape(colnames(rowLabels)))
 
-  clabels <- attr(object, "colLabels")
+  clabels <- do_escape(attr(object, "colLabels"))
   cjust <- attr(clabels, "justification")
   ind <- is.na(cjust)
   cjust[ind] <- defjust
 
   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 == ""] <- "&nbsp;"
-  clabels <- ifelse(multi == 0, "", sprintf('  <th%s%s>%s</th>\n', colspan, class, clabels))
+  clabels <- ifelse(multi == 0,
+                    "",
+                    sprintf('  <th%s%s>%s</th>\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)
   }
 
   if (opts$doHTMLbody)
     mycat(opts$HTMLbody)
 
   if (opts$doBegin) {
-    if (is.null(id)) 
+    if (is.null(id))
       id <- ""
     else
       id <- sprintf(' id="%s"', id)
@@ -147,7 +151,7 @@ toHTML <- function(object, file = "",
     mycat(sprintf('<caption>%s</caption>\n', opts$HTMLcaption))
 
   if (opts$doHeader) {
-    rows <- apply(cbind(rowLabelHeadings, clabels), 1, paste0, collapse="")
+    rows <- apply(cbind(rowLabelHeadings, clabels), 1, paste0, collapse = "")
     mycat('<thead>\n')
     mycat(sprintf('<tr class="%s">\n%s</tr>\n', CSSclassname(defjust), rows))
     mycat('</thead>\n')
@@ -158,7 +162,7 @@ toHTML <- function(object, file = "",
     mycat('</tfoot>\n')
   }
   if (opts$doBody) {
-    rows <- apply(cbind(rowLabels, chars), 1, paste0, collapse="")
+    rows <- apply(cbind(rowLabels, chars), 1, paste0, collapse = "")
     mycat('<tbody>\n')
     mycat(sprintf('<tr class="%s">\n%s</tr>\n', CSSclassname(defjust), rows))
     mycat('</tbody>\n')
@@ -169,7 +173,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 +186,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)
 }
-

R/latex.tabular.R

@@ -1,12 +1,7 @@
-texify <- function(x) {
-    x <- gsub("\\", "\\textbackslash{}", x, fixed = TRUE)
-    if (requireNamespace("Hmisc"))
-        x <- Hmisc::latexTranslate(x)
-    x
-}
 
 toLatex.tabular <- function(object, file = "", options = NULL, 
-                            append = FALSE, ...) {
+                            append = FALSE, 
+                            ...) {
 
   if (!is.null(options)) {
     saveopts <- do.call(table_options, options)
@@ -24,17 +19,26 @@ toLatex.tabular <- function(object, file = "", options = NULL,
       output <<- paste0(output, paste(args, collapse = sep))
   }
 
+  escape <- opts$escape
+
+  do_escape <- function(x) {
+    if (escape) 
+      x <- texify(x)
+    x
+  }
+
   chars <- format(object, latex = TRUE, minus = opts$latexminus, 
                   leftpad = opts$latexleftpad, 
-                  rightpad = opts$latexrightpad,...) # format without justification
+                  rightpad = opts$latexrightpad,
+                  ...) # format without justification
 
   vjust <- attr(object, "justification")
   vjustdefs <- rep(opts$justification, length.out=ncol(object))
   ind <- !is.na(vjust) & vjust != rep(vjustdefs, each=nrow(vjust))
   chars[ind] <- sprintf("\\multicolumn{1}{%s}{%s}",
                         vjust[ind], chars[ind])
 
-  rowLabels <- attr(object, "rowLabels")
+  rowLabels <- do_escape(attr(object, "rowLabels"))
   nleading <- ncol(rowLabels)
   rowLabels[is.na(rowLabels)] <- ""
   rjust <- attr(rowLabels, "justification")
@@ -49,8 +53,8 @@ toLatex.tabular <- function(object, file = "", options = NULL,
   colnamejust[ind] <- rjustdefs[ind]
   ind <- colnamejust != rjustdefs
   colnames(rowLabels)[ind] <- sprintf("\\multicolumn{1}{%s}{%s}", 
-                                      colnamejust[ind], colnames(rowLabels)[ind])
-  clabels <- attr(object, "colLabels")
+                                      colnamejust[ind], do_escape(colnames(rowLabels)[ind]))
+  clabels <- do_escape(attr(object, "colLabels"))
   leadin <- paste(rep("&", max(nleading - 1, 0)), collapse=" ")
   cjust <- attr(clabels, "justification")
   ind <- is.na(cjust)