Added math.style.exponents option to print.xtable via a change to

sanitize.numbers

git-svn-id: svn://scm.r-forge.r-project.org/svnroot/xtable@87 edb9625f-4e0d-4859-8d74-9fd3b1da38cb

diff --git a/pkg/NEWS b/pkg/NEWS
index fba84048d2c0ed482e4af7cd3186569a9c938636..4d24a5e1daddbcc3acf3f73bd64fccde83916013 100644 (file)
--- a/pkg/NEWS
+++ b/pkg/NEWS
@@ -1,4 +1,4 @@
-1.8-1 (NOT YET SUBMITTED TO CRAN)
+1.8-2 (NOT YET SUBMITTED TO CRAN)
   * 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
@@ -8,6 +8,9 @@
     sphet.
   * Extracted sanitize functions from print.xtable as stand-alone
     functions, and exported them.
+  * Added option to produce math style exponents when sanitizing
+    numbers, as suggested by Don Armstrong (don@donarmstrong.com), who
+    also provided code
 
 
 1.8-0

diff --git a/pkg/R/print.xtable.R b/pkg/R/print.xtable.R
index 1cbf37f141c60123426c27e0958b233da75f5e02..b3b4b9a4178eb834021257cc0efbccd0160eb852 100644 (file)
--- a/pkg/R/print.xtable.R
+++ b/pkg/R/print.xtable.R
@@ -45,6 +45,7 @@ print.xtable <- function(x,
   sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",\r
                                          sanitize.text.function),\r
   math.style.negative = getOption("xtable.math.style.negative", FALSE),\r
+  math.style.exponents = getOption("xtable.math.style.exponents", FALSE),\r
   html.table.attributes = getOption("xtable.html.table.attributes", "border=1"),\r
   print.results = getOption("xtable.print.results", TRUE),\r
   format.args = getOption("xtable.format.args", NULL),\r
@@ -537,7 +538,8 @@ print.xtable <- function(x,
     if ( is.numeric.column ) {\r
       cols[, i+pos] <-\r
         sanitize.numbers(cols[, i+pos], type = type,\r
-                         math.style.negative = math.style.negative)\r
+                         math.style.negative = math.style.negative,\r
+                         math.style.exponents = math.style.exponents)\r
     } else {\r
       if (is.null(sanitize.text.function)) {\r
         cols[, i+pos] <- sanitize(cols[, i+pos], type = type)\r

diff --git a/pkg/R/sanitize.R b/pkg/R/sanitize.R
index 1313a96a4e2f89199907e8ae5f460f10c16b4c0a..18c6619e19e1e5af6099a091f7d39169f6c28ed4 100644 (file)
--- a/pkg/R/sanitize.R
+++ b/pkg/R/sanitize.R
@@ -26,7 +26,9 @@ sanitize <- function(str, type) {
 }
 
 
-sanitize.numbers <- function(str, type, math.style.negative){
+sanitize.numbers <- function(str, type,
+                             math.style.negative = FALSE,
+                             math.style.exponents = FALSE){
   if (type == "latex"){
     result <- str
     if ( math.style.negative ) {
@@ -34,6 +36,40 @@ sanitize.numbers <- function(str, type, math.style.negative){
         result[i] <- gsub("-", "$-$", result[i], fixed = TRUE)
       }
     }
+    if ( math.style.exponents ) {
+      if (is.logical(math.style.exponents) && ! math.style.exponents ) {
+      } else if (is.logical(math.style.exponents) && math.style.exponents ||
+                 math.style.exponents == "$$"
+                 ) {
+        for(i in 1:length(str)) {
+          result[i] <-
+            gsub("^\\$?(-?)\\$?([0-9.]+)[eE]\\$?(-?)\\+?\\$?0*(\\d+)$",
+                 "$\\1\\2 \\\\times 10^{\\3\\4}$", result[i])
+        }
+      } else if (math.style.exponents == "ensuremath") {
+        for(i in 1:length(str)) {
+          result[i] <-
+            gsub("^\\$?(-?)\\$?([0-9.]+)[eE]\\$?(-?)\\+?\\$?0*(\\d+)$",
+                 "\\\\ensuremath{\\1\\2 \\\\times 10^{\\3\\4}}",
+                 result[i])
+        }
+      } else if (math.style.exponents == "UTF8" ||
+                 math.style.exponents == "UTF-8") {
+        for(i in 1:length(str)) {
+          ## this code turns 1e5 into 1×10⁵x
+          if (all(grepl("^\\$?(-?)\\$?([0-9.]+)[eE]\\$?(-?)\\+?\\$?0*(\\d+)$",
+                        result[i]))) {
+            temp <- strsplit(result[i],"eE",result[i])
+            result[i] <-
+              paste0(temp[1],
+                     "\u00d710",
+                     chartr("-1234567890",
+                            "\u207b\u00b9\u00b2\u00b3\u2074\u2075\u20746\u20747\u20748\u20749\u2070",
+                            temp[2]))
+          }
+        }
+      }
+    }
     return(result)
   } else {
     return(str)
@@ -47,7 +83,7 @@ sanitize.final <- function(str, type){
   } else {
     str$text <- gsub("  *", " ",  str$text, fixed = TRUE)
     str$text <- gsub(' align="left"',  "", str$text,
-                        fixed = TRUE)
+                     fixed = TRUE)
     return(str)
   }
 }

diff --git a/pkg/R/table.attributes.R b/pkg/R/table.attributes.R
index 718e41fc958a19b956c132ff7b4236014cdaf0d2..9932cef15485e6c66b4ee35a97e117875f990ff7 100644 (file)
--- a/pkg/R/table.attributes.R
+++ b/pkg/R/table.attributes.R
@@ -20,56 +20,57 @@
 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 ### MA 02111-1307, USA
 
-"caption<-" <- function(x,value) UseMethod("caption<-")
-"caption<-.xtable" <- function(x,value) {
-  if (length(value)>2)
+"caption<-" <- function(x, value) UseMethod("caption<-")
+"caption<-.xtable" <- function(x, value) {
+  if (length(value) > 2)
     stop("\"caption\" must have length 1 or 2")
-  attr(x,"caption") <- value
+  attr(x, "caption") <- value
   return(x)
 }
 
-caption <- function(x,...) UseMethod("caption")
-caption.xtable <- function(x,...) {
-  return(attr(x,"caption",exact=TRUE))
+caption <- function(x, ...) UseMethod("caption")
+caption.xtable <- function(x, ...) {
+  return(attr(x, "caption", exact = TRUE))
 }
 
-"label<-" <- function(x,value) UseMethod("label<-")
-"label<-.xtable" <- function(x,value) {
-  if (length(value)>1)
+"label<-" <- function(x, value) UseMethod("label<-")
+"label<-.xtable" <- function(x, value) {
+  if (length(value) > 1)
     stop("\"label\" must have length 1")
-  attr(x,"label") <- value
+  attr(x, "label") <- value
   return(x)
 }
 
-label <- function(x,...) UseMethod("label")
-label.xtable <- function(x,...) {
-  return(attr(x,"label",exact=TRUE))
+label <- function(x, ...) UseMethod("label")
+label.xtable <- function(x, ...) {
+  return(attr(x, "label", exact = TRUE))
 }
 
-"align<-" <- function(x,value) UseMethod("align<-")
+"align<-" <- function(x, value) UseMethod("align<-")
 
-# Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
+### Based on contribution from Jonathan Swinton <jonathan@swintons.net>
+### in e-mail dated Wednesday, January 17, 2007
 .alignStringToVector <- function(aString) {
-  # poor mans parsing - separating string of form "l{2in}llr|p{1in}c|{1in}"
-  # into "l{2in}" "l"      "l"      "r"      "|"      "p{1in}" "c"      "|{1in}"
+  ## poor mans parsing - separating string of form "l{2in}llr|p{1in}c|{1in}"
+  ## into "l{2in}" "l"  "l"  "r" "|" "p{1in}" "c" "|{1in}"
   aString.Align <- character(0);
   aString.Width <- character(0);
   wString <- aString
-  while( nchar(wString)>0) {
-    aString.Align <- c(aString.Align,substr(wString,1,1))
-    # is it followed by a brace?
+  while( nchar(wString) > 0) {
+    aString.Align <- c(aString.Align, substr(wString, 1, 1))
+    ## is it followed by a brace?
     thisWidth <- ""
-    if ( nchar(wString)>1 & substr(wString,2,2)=="{") {
-      beforeNextBrace <- regexpr("[^\\]\\}",wString)
+    if ( nchar(wString) > 1 & substr(wString, 2, 2) == "{") {
+      beforeNextBrace <- regexpr("[^\\]\\}", wString)
       if (beforeNextBrace <0 ) {
         stop("No closing } in align string")
       }
-      thisWidth <- substr(wString,2,beforeNextBrace+1)
-      wString <- substr(wString,beforeNextBrace+2,nchar(wString))
+      thisWidth <- substr(wString, 2, beforeNextBrace + 1)
+      wString <- substr(wString, beforeNextBrace + 2, nchar(wString))
     } else {
-      wString <- substr(wString,2,nchar(wString))
+      wString <- substr(wString, 2, nchar(wString))
     }
-    aString.Width <- c(aString.Width,thisWidth)
+    aString.Width <- c(aString.Width, thisWidth)
   }
 
   alignAllowed <- c("l","r","p","c","|","X")
@@ -77,78 +78,84 @@ label.xtable <- function(x,...) {
   if (any( !(aString.Align %in% alignAllowed))) {
     warning("Nonstandard alignments in align string")
   }
-  res <- paste(aString.Align,aString.Width,sep="")
+  res <- paste(aString.Align, aString.Width, sep = "")
   res
 }
-#.alignStringToVector ("l{2in}llr|p{1in}c|{1in}")
-#.alignStringToVector ("l{2in}llr|p{1in}c|")
-#.alignStringToVector ("{2in}llr|p{1in}c|") # latex syntax error, but gives wrong alignment
-#.alignStringToVector("llllp{3cm}")
-
-"align<-.xtable" <- function(x,value) {
-# Based on contribution from Benno <puetz@mpipsykl.mpg.de> in e-mail dated Wednesday, December 01, 2004
-# Based on contribution from Jonathan Swinton <jonathan@swintons.net> in e-mail dated Wednesday, January 17, 2007
-  # cat("%",value,"\n")
-  if ( (!is.null(value)) && ( is.character(value) ) && ( length(value) == 1 ) && ( nchar(value) > 1 ) ) {
+###.alignStringToVector ("l{2in}llr|p{1in}c|{1in}")
+###.alignStringToVector ("l{2in}llr|p{1in}c|")
+### latex syntax error, but gives wrong alignment
+###.alignStringToVector ("{2in}llr|p{1in}c|")
+###.alignStringToVector("llllp{3cm}")
+
+"align<-.xtable" <- function(x, value) {
+### Based on contribution from Benno <puetz@mpipsykl.mpg.de>
+### in e-mail dated Wednesday, December 01, 2004
+### Based on contribution from Jonathan Swinton <jonathan@swintons.net>
+### in e-mail dated Wednesday, January 17, 2007
+  ## cat("%", value, "\n")
+  if ( (!is.null(value)) && ( is.character(value) ) &&
+       ( length(value) == 1 ) && ( nchar(value) > 1 ) ) {
         value <- .alignStringToVector(value)
-  } # That should have checked we had only lrcp|
-    # but what if the "if statement" is false?
-    # For simplicity, deleting check present in version 1.4-2 and earlier.
-  c.value <- if (any(!is.na(match(value,"|")))) {
-                value[-which(value=='|')]
+  }
+  ## That should have checked we had only lrcp|
+  ## but what if the "if statement" is false?
+  ## For simplicity, deleting check present in version 1.4-2 and earlier.
+  c.value <- if (any(!is.na(match(value, "|")))) {
+               value[-which(value == '|')]
              } else {
-                value
+               value
              }
-  if (length(c.value)!=ncol(x)+1)
-      stop(paste("\"align\" must have length equal to",ncol(x)+1,"( ncol(x) + 1 )"))
-
-  attr(x,"align") <- value
+  if (length(c.value) != ncol(x) + 1)
+    stop(paste("\"align\" must have length equal to",
+               ncol(x) + 1, "( ncol(x) + 1 )"))
+  attr(x, "align") <- value
   return(x)
 }
 
-align <- function(x,...) UseMethod("align")
-align.xtable <- function(x,...) {
-  return(attr(x,"align",exact=TRUE))
+align <- function(x, ...) UseMethod("align")
+align.xtable <- function(x, ...) {
+  return(attr(x, "align", exact = TRUE))
 }
 
-"digits<-" <- function(x,value) UseMethod("digits<-")
-"digits<-.xtable" <- function(x,value) {
+"digits<-" <- function(x, value) UseMethod("digits<-")
+"digits<-.xtable" <- function(x, value) {
   if( is.matrix( value ) ) {
-    if( ncol( value ) != ncol(x)+1 || nrow( value ) != nrow(x) ) {
+    if( ncol( value ) != ncol(x) + 1 || nrow( value ) != nrow(x) ) {
       stop( "if argument 'digits' is a matrix, it must have columns equal",
-        " to ", ncol(x)+1, " ( ncol(x) + 1 ) and rows equal to ", nrow(x),
-        " ( nrow( x )" )
+           " to ", ncol(x) + 1, " ( ncol(x) + 1 ) and rows equal to ", nrow(x),
+           " ( nrow( x )" )
     }
   } else {
-    if( length(value)==1 ) { value <- rep(value, ncol(x)+1) }
-    if( length( value ) >1 & length( value ) != ncol(x)+1 ) {
+    if( length(value) == 1 ) { value <- rep(value, ncol(x) + 1) }
+    if( length( value ) > 1 & length( value ) != ncol(x) + 1 ) {
       stop( "if argument 'digits' is a vector of length more than one, it must have length equal",
-        " to ", ncol(x)+1, " ( ncol(x) + 1 )" )
+           " to ", ncol(x) + 1, " ( ncol(x) + 1 )" )
     }
   }
   if (!is.numeric(value))
     stop("\"digits\" must be numeric")
-  attr(x,"digits") <- value
+  attr(x, "digits") <- value
   return(x)
 }
 
-digits <- function(x,...) UseMethod("digits")
-digits.xtable <- function(x,...) {
-  return(attr(x,"digits",exact=TRUE))
+digits <- function(x, ...) UseMethod("digits")
+digits.xtable <- function(x, ...) {
+  return(attr(x, "digits", exact = TRUE))
 }
 
-"display<-" <- function(x,value) UseMethod("display<-")
-"display<-.xtable" <- function(x,value) {
-  if (length(value)!=ncol(x)+1)
-    stop(paste("\"display\" must have length equal to",ncol(x)+1,"( ncol(x) + 1 )"))
-  if (!all(!is.na(match(value,c("d","f","e","E","g","G","fg","s")))))
+"display<-" <- function(x, value) UseMethod("display<-")
+"display<-.xtable" <- function(x, value) {
+  if (length(value) != ncol(x) + 1)
+    stop(paste("\"display\" must have length equal to",
+               ncol(x) + 1, "( ncol(x) + 1 )"))
+  if (!all(!is.na(match(value, c("d","f","e","E","g","G","fg","s")))))
     stop("\"display\" must be in {\"d\",\"f\",\"e\",\"E\",\"g\",\"G\", \"fg\", \"s\"}")
-  attr(x,"display") <- value
+  attr(x, "display") <- value
   return(x)
 }
 
-display <- function(x,...) UseMethod("display")
-display.xtable <- function(x,...) {
-  return(attr(x,"display",exact=TRUE))
+display <- function(x, ...) UseMethod("display")
+display.xtable <- function(x, ...) {
+  return(attr(x, "display", exact = TRUE))
 }
 

diff --git a/pkg/man/print.xtable.Rd b/pkg/man/print.xtable.Rd
index ba3b45d345f1691d3e92c1de4e52f045f7759e92..c8ca65494056f4f580de933004414c0b3b428fe3 100644 (file)
--- a/pkg/man/print.xtable.Rd
+++ b/pkg/man/print.xtable.Rd
@@ -30,6 +30,7 @@
   sanitize.colnames.function = getOption("xtable.sanitize.colnames.function",\r
                                          sanitize.text.function),\r
   math.style.negative = getOption("xtable.math.style.negative", FALSE),\r
+  math.style.exponents = getOption("xtable.math.style.exponents", FALSE),\r
   html.table.attributes = getOption("xtable.html.table.attributes",\r
                                     "border=1"),\r
   print.results = getOption("xtable.print.results", TRUE),\r
@@ -137,6 +138,12 @@
     The default uses the \code{sanitize.text.function}. }\r
   \item{math.style.negative}{In a LaTeX table, if \code{TRUE}, then use\r
     $-$ for the negative sign (as was the behavior prior to version 1.5-3).\r
+    Default value is \code{FALSE}.}  \r
+  \item{math.style.exponents}{In a LaTeX table, if \code{TRUE} or\r
+    \code{"$$"}, then use \verb{$5 \times 10^{5}$} for 5e5. If\r
+    \code{"ensuremath"}, then use \verb{\\ensuremath{5 \times 10^{5}}}\r
+    for 5e5. If \code{"UTF-8"} or \code{"UTF-8"}, then use UTF-8 to\r
+    approximate the LaTeX typsetting for 5e5.\r
     Default value is \code{FALSE}.}\r
   \item{html.table.attributes}{In an HTML table, attributes associated\r
     with the \code{<TABLE>} tag.\r

diff --git a/pkg/man/sanitize.Rd b/pkg/man/sanitize.Rd
index aa4624763feb786f0426b263c27d42a123336a97..3bba1072e6ee4b31800932c0833a75aae2c8ca63 100644 (file)
--- a/pkg/man/sanitize.Rd
+++ b/pkg/man/sanitize.Rd
@@ -13,7 +13,8 @@
 }\r
 \usage{\r
 sanitize(str, type)\r
-sanitize.numbers(str, type, math.style.negative)\r
+sanitize.numbers(str, type, math.style.negative = FALSE,\r
+                 math.style.exponents = FALSE)\r
 sanitize.final(str, type)\r
 }\r
 \r
@@ -25,6 +26,12 @@ sanitize.final(str, type)
   \item{math.style.negative}{In a LaTeX table, if \code{TRUE}, then use\r
     $-$ for the negative sign (as was the behavior prior to version 1.5-3).\r
     Default value is \code{FALSE}.}\r
+  \item{math.style.exponents}{In a LaTeX table, if \code{TRUE} or\r
+    \code{"$$"}, then use \verb{$5 \times 10^{5}$} for 5e5. If\r
+    \code{"ensuremath"}, then use \verb{\ensuremath{5 \times 10^{5}}}\r
+    for 5e5. If \code{"UTF-8"} or \code{"UTF-8"}, then use UTF-8 to\r
+    approximate the LaTeX typsetting for 5e5.\r
+    Default value is \code{FALSE}.}\r
 }\r
 \details{\r
 \r
@@ -42,6 +49,12 @@ sanitize.final(str, type)
   \code{"latex"}, $-$ is used for the negative sign rather than a\r
   simple hyphen (-). No effect when \code{type} is \code{"html"}.\r
 \r
+  When \code{type} is \code{"latex"}, and \code{math.style.exponents}\r
+  is \code{TRUE} or \verb{"$$"}, then use \verb{$5 \times 10^{5}$} for\r
+  5e5. If \code{"ensuremath"}, then use \verb{\ensuremath{5 \times\r
+  10^{5}}} for 5e5. If \code{"UTF-8"} or \code{"UTF-8"}, then use UTF-8\r
+  to approximate the LaTeX typsetting for 5e5.\r
+\r
   When \code{type} is \code{"latex"} \code{sanitize.final} has no\r
   effect. When \code{type} is \code{"html"}, multiple spaces are\r
   replaced by a single space and occurrences of \code{' align="left"'}\r
@@ -72,7 +85,8 @@ names(insane) <- c("Ampersand","Greater than","Less than")
 sanitize(insane, type = "html")\r
 x <- rnorm(10)\r
 sanitize.numbers(x, "latex", TRUE)\r
-sanitize.numbers(x, "html", TRUE)\r
+sanitize.numbers(x*10^(10), "latex", TRUE, TRUE)\r
+sanitize.numbers(x, "html", TRUE, TRUE)\r
 }\r
 \r
 \keyword{print }\r

diff --git a/pkg/vignettes/xtableGallery.Rnw b/pkg/vignettes/xtableGallery.Rnw
index 6b7d47b3327244659e9d49a14a5c1a181019a941..1349096ab6c1be2d729016bae8bf2f913ffd4162 100644 (file)
--- a/pkg/vignettes/xtableGallery.Rnw
+++ b/pkg/vignettes/xtableGallery.Rnw
@@ -188,6 +188,25 @@ autoformat(x)
 \r
 \newpage\r
 \r
+\subsection{Math-Style Exponents}\r
+If you prefer $5 \times 10^5$ in your tables to 5e5, the\r
+\code{math.style.exponents} option to \code{print.xtable} is useful:\r
+\r
+<<results='asis'>>=\r
+print(xtable(data.frame(text=c("foo","bar"),\r
+                        googols=c(10e10,50e10),\r
+                        small=c(8e-24,7e-5),\r
+                        row.names=c("A","B")),\r
+             display=c("s","s","g","g")),\r
+      math.style.exponents=TRUE\r
+      )\r
+@ \r
+\r
+this option also supports the values \code{ensuremath} which uses\r
+\code{\char`\\ensuremath} instead of \code{\$\$} and \code{UTF-8}\r
+which uses UTF-8 to approximate the \LaTeX typesetting.\r
+\r
+\r
 \section{Sanitization}\r
 <<results='asis'>>=\r
 insane <- data.frame(Name = c("Ampersand","Greater than","Less than",\r