fixed logicals bug (number 1911)

reformatted xtable.R to put spaces around "=" and after ","
added tests directory

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

diff --git a/pkg/DESCRIPTION b/pkg/DESCRIPTION
index 463f0dfc43eb9a84f3f4ab8c6d83d99771bd981a..ae32544c8fc5ab34bc1755bb994472281c24bd83 100644 (file)
--- a/pkg/DESCRIPTION
+++ b/pkg/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: xtable
-Version: 1.7-0
-Date: 2012/02/06
+Version: 1.7-1
+Date: 2012/08/10
 Title: Export tables to LaTeX or HTML
 Author: David B. Dahl <dahl@stat.tamu.edu>
 Maintainer: Charles Roosen <statsci@gmail.com>

diff --git a/pkg/NEWS b/pkg/NEWS
index 5f5356d72153ef1111a57c28818d6cb124cbd8ce..47537ba3a5965db4a5ec0f9db850be63b2770e78 100644 (file)
--- a/pkg/NEWS
+++ b/pkg/NEWS
@@ -1,4 +1,7 @@
-1.7-0 (NOT YET RELEASED)
+1.7-1 (NOT YET RELEASED)
+  * Fixed logicals bug (number 1911)
+
+1.7-0
   * Added some vectorization code to improve performance.
   * Let "caption" be length 2, in which case the second value is 
     the short caption used when creating a list of tables.

diff --git a/pkg/R/xtable.R b/pkg/R/xtable.R
index d6bc227846ebe609f1a542d53a2e7ca14a447e70..6c65954d31ad642905cac55842e49360c0e8ce7e 100644 (file)
--- a/pkg/R/xtable.R
+++ b/pkg/R/xtable.R
@@ -20,28 +20,31 @@
 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 ### MA 02111-1307, USA
 
-xtable <- function(x,caption=NULL,label=NULL,align=NULL,
-                   digits=NULL,display=NULL,...) {
+xtable <- function(x, caption = NULL, label = NULL, align = NULL,
+                   digits = NULL, display = NULL, ...) {
   UseMethod("xtable")
 }
 
 
 ## data.frame and matrix objects
 
-xtable.data.frame <- function(x,caption=NULL,label=NULL,align=NULL,
-                              digits=NULL,display=NULL,...) {
-  logicals <- unlist(lapply(x,is.logical))
-  x[,logicals] <- lapply(x[,logicals], as.character)
-  characters <- unlist(lapply(x,is.character))
-  factors <- unlist(lapply(x,is.factor))
+xtable.data.frame <- function(x, caption = NULL, label = NULL, align = NULL,
+                              digits = NULL, display = NULL, ...) {
+  logicals <- unlist(lapply(x, is.logical))
+  ##x[, logicals] <- lapply(x[, logicals], as.character)
+  ## Patch for logicals bug, no 1911
+  ## David Scott, <d.scott@auckland.ac.nz>, 2012-08-10
+  x[, logicals] <- lapply(x[, logicals, drop = FALSE], as.character)
+  characters <- unlist(lapply(x, is.character))
+  factors <- unlist(lapply(x, is.factor))
   ints <- sapply(x, is.integer)
   class(x) <- c("xtable","data.frame")
   caption(x) <- caption
   label(x) <- label
   align(x) <- switch(1+is.null(align), align,
                      c("r",c("r","l")[(characters|factors)+1]))
-  digits(x) <- switch(1+is.null(digits),digits,c(0,rep(2,ncol(x))))
-  # Patch from Seth Falcon <sfalcon@fhcrc.org>, 18-May-2007
+  digits(x) <- switch(1+is.null(digits), digits, c(0,rep(2,ncol(x))))
+  ## Patch from Seth Falcon <sfalcon@fhcrc.org>, 18-May-2007
   if (is.null(display)) {
       display <- rep("f", ncol(x))
       display[ints] <- "d"
@@ -52,21 +55,29 @@ xtable.data.frame <- function(x,caption=NULL,label=NULL,align=NULL,
   return(x)
 }
 
-xtable.matrix <- function(x,caption=NULL,label=NULL,align=NULL,
-                          digits=NULL,display=NULL,...) {
-  return(xtable.data.frame(data.frame(x,check.names=FALSE),
-                           caption=caption,label=label,align=align,
-                           digits=digits,display=display))
+xtable.matrix <- function(x, caption = NULL, label = NULL, align = NULL,
+                          digits = NULL, display = NULL, ...) {
+  return(xtable.data.frame(data.frame(x, check.names = FALSE),
+                           caption = caption, label = label, align = align,
+                           digits = digits, display = display))
 }
 
 
-## table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
-## Fixed to pass R checks by DBD, 9 May 2007
-xtable.table<-function(x,caption=NULL,label=NULL,align=NULL, digits=NULL,display=NULL,...) {
-  if (length(dim(x))==1) {
-    return(xtable.matrix(matrix(x,dimnames=list(rownames(x),names(dimnames(x)))),caption=caption,label=label,align=align,digits=digits,display=display))
+### table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
+### Fixed to pass R checks by DBD, 9 May 2007
+xtable.table <- function(x, caption = NULL, label = NULL, align = NULL,
+                       digits = NULL, display = NULL, ...) {
+  if (length(dim(x)) == 1) {
+    return(xtable.matrix(matrix(x,
+                                dimnames = list(rownames(x),
+                                                names(dimnames(x)))),
+                         caption = caption, label = label,
+                         align = align, digits = digits, display = display))
   } else if (length(dim(x))==2) {
-    return(xtable.matrix(matrix(x,ncol=dim(x)[2],nrow=dim(x)[1],dimnames=list(rownames(x),colnames(x))),caption=caption,label=label,align=align,digits=digits,display=display))
+    return(xtable.matrix(matrix(x, ncol = dim(x)[2], nrow = dim(x)[1],
+                                dimnames = list(rownames(x), colnames(x))),
+                         caption = caption, label = label,
+                         align = align, digits = digits, display = display))
   } else {
     stop("xtable.table is not implemented for tables of > 2 dimensions")
   }
@@ -75,119 +86,128 @@ xtable.table<-function(x,caption=NULL,label=NULL,align=NULL, digits=NULL,display
 
 ## anova objects
 
-xtable.anova <- function(x,caption=NULL,label=NULL,align=NULL,
-                         digits=NULL,display=NULL,...) {
-  suggested.digits <- c(0,rep(2,ncol(x)))
-  suggested.digits[grep("Pr\\(>",names(x))+1] <- 4
-  suggested.digits[grep("P\\(>",names(x))+1] <- 4
-  suggested.digits[grep("Df",names(x))+1] <- 0
+xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
+                         digits = NULL, display = NULL, ...) {
+  suggested.digits <- c(0,rep(2, ncol(x)))
+  suggested.digits[grep("Pr\\(>", names(x))+1] <- 4
+  suggested.digits[grep("P\\(>", names(x))+1] <- 4
+  suggested.digits[grep("Df", names(x))+1] <- 0
 
   class(x) <- c("xtable","data.frame")
   caption(x) <- caption
   label(x) <- label
-  align(x) <- switch(1+is.null(align),align,c("l",rep("r",ncol(x))))
-  digits(x) <- switch(1+is.null(digits),digits,suggested.digits)
-  display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
+  align(x) <- switch(1+is.null(align), align, c("l",rep("r", ncol(x))))
+  digits(x) <- switch(1+is.null(digits), digits, suggested.digits)
+  display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
   return(x)
 }
 
 
 ## aov objects
 
-xtable.aov <- function(x,caption=NULL,label=NULL,align=NULL,
-                       digits=NULL,display=NULL,...) {
-  return(xtable.anova(anova(x,...),caption=caption,label=label,
-                      align=align, digits=digits,display=display))
+xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
+                       digits = NULL, display = NULL, ...) {
+  return(xtable.anova(anova(x, ...), caption = caption, label = label,
+                      align = align, digits = digits, display = display))
 }
 
-xtable.summary.aov <- function(x,caption=NULL,label=NULL,align=NULL,
-                               digits=NULL,display=NULL,...) {
-  return(xtable.anova(x[[1]],caption=caption,label=label,
-                      align=align, digits=digits,display=display))
+xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
+                               digits = NULL, display = NULL, ...) {
+  return(xtable.anova(x[[1]], caption = caption, label = label,
+                      align = align, digits = digits, display = display))
 }
 
-xtable.summary.aovlist <- function(x,caption=NULL,label=NULL,align=NULL,
-                                   digits=NULL,display=NULL,...) {
-  for(i in 1:length(x)) {
-    if (i==1) result <- xtable.summary.aov(x[[i]],caption=caption,label=label,
-          align=align, digits=digits,display=display)
-    else result <- rbind(result,xtable.anova(x[[i]][[1]],caption=caption,
-                                             label=label, align=align,
-                                             digits=digits,display=display))
-  }
-  return(result)
+xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
+                                   align = NULL,
+                                   digits = NULL, display = NULL, ...) {
+    for (i in 1:length(x)) {
+        if (i == 1) {
+            result <- xtable.summary.aov(x[[i]], caption = caption,
+                                         label = label,
+                                         align = align, digits = digits,
+                                         display = display)
+        } else {
+            result <- rbind(result,
+                            xtable.anova(x[[i]][[1]], caption = caption,
+                                         label = label, align = align,
+                                         digits = digits, display = display))
+        }
+    }
+    return(result)
 }
 
-xtable.aovlist <- function(x,caption=NULL,label=NULL,align=NULL,
-                           digits=NULL,display=NULL,...) {
-  return(xtable.summary.aovlist(summary(x),caption=caption,label=label,
-                                align=align, digits=digits,display=display))
+xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
+                           digits = NULL, display = NULL, ...) {
+  return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
+                                align = align, digits = digits,
+                                display = display))
 }
 
 
 
 ## lm objects
 
-xtable.lm <- function(x,caption=NULL,label=NULL,align=NULL,
-                      digits=NULL,display=NULL,...) {
-  return(xtable.summary.lm(summary(x),caption=caption,label=label,
-                           align=align, digits=digits,display=display))
+xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
+                      digits = NULL, display = NULL, ...) {
+  return(xtable.summary.lm(summary(x), caption = caption, label = label,
+                           align = align, digits = digits, display = display))
 }
 
-xtable.summary.lm <- function(x,caption=NULL,label=NULL,align=NULL,
-                              digits=NULL,display=NULL,...) {
-  x <- data.frame(x$coef,check.names=FALSE)
+xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
+                              digits = NULL, display = NULL, ...) {
+  x <- data.frame(x$coef, check.names = FALSE)
 
   class(x) <- c("xtable","data.frame")
   caption(x) <- caption
   label(x) <- label
-  align(x) <- switch(1+is.null(align),align,c("r","r","r","r","r"))
-  digits(x) <- switch(1+is.null(digits),digits,c(0,4,4,2,4))
-  display(x) <- switch(1+is.null(display),display,c("s","f","f","f","f"))
+  align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
+  digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
+  display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
   return(x)
 }
 
 
 ## glm objects
 
-xtable.glm <- function(x,caption=NULL,label=NULL,align=NULL,
-                       digits=NULL,display=NULL,...) {
-  return(xtable.summary.glm(summary(x),caption=caption,label=label,align=align,
-                            digits=digits,display=display))
+xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
+                       digits = NULL, display = NULL, ...) {
+  return(xtable.summary.glm(summary(x), caption = caption,
+                            label = label, align = align,
+                            digits = digits, display = display))
 }
 
-xtable.summary.glm <- function(x,caption=NULL,label=NULL,align=NULL,
-                               digits=NULL,display=NULL,...) {
-  return(xtable.summary.lm(x,caption=caption,label=label,
-                           align=align, digits=digits,display=display))
+xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
+                               digits = NULL, display = NULL, ...) {
+  return(xtable.summary.lm(x, caption = caption, label = label,
+                           align = align, digits = digits, display = display))
 }
 
 
 ## prcomp objects
 
-xtable.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
-                          digits=NULL,display=NULL,...) {
-  x <- data.frame(x$rotation,check.names=FALSE)
+xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
+                          digits = NULL, display = NULL, ...) {
+  x <- data.frame(x$rotation, check.names = FALSE)
 
   class(x) <- c("xtable","data.frame")
   caption(x) <- caption
   label(x) <- label
-  align(x) <- switch(1+is.null(align),align,c("r",rep("r",ncol(x))))
-  digits(x) <- switch(1+is.null(digits),digits,c(0,rep(4,ncol(x))))
-  display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
+  align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
+  digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
+  display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
   return(x)
 }
 
-xtable.summary.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
-                                  digits=NULL,display=NULL,...) {
-  x <- data.frame(x$importance,check.names=FALSE)
+xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
+                                  digits = NULL, display = NULL, ...) {
+  x <- data.frame(x$importance, check.names = FALSE)
 
   class(x) <- c("xtable","data.frame")
   caption(x) <- caption
   label(x) <- label
-  align(x) <- switch(1+is.null(align),align,c("r",rep("r",ncol(x))))
-  digits(x) <- switch(1+is.null(digits),digits,c(0,rep(4,ncol(x))))
-  display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
+  align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
+  digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
+  display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
   return(x)
 }
 
@@ -196,8 +216,8 @@ xtable.summary.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
 #   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 #   From: Jun Yan <jyan@stat.wisc.edu>
 #   Subject: Re: [R] xtable for Cox model output
-xtable.coxph <- function (x,caption=NULL,label=NULL,align=NULL,
-                          digits=NULL,display=NULL,...)
+xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
+                          digits = NULL, display = NULL, ...)
 {
   cox <- x
   beta <- cox$coef
@@ -220,8 +240,8 @@ xtable.coxph <- function (x,caption=NULL,label=NULL,align=NULL,
 # Additional method: xtable.ts
 # Contributed by David Mitchell (davidm@netspeed.com.au)
 # Date: July 2003
-xtable.ts <- function(x,caption=NULL,label=NULL,align=NULL,
-                      digits=NULL,display=NULL,...) {
+xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
+                      digits = NULL, display = NULL, ...) {
   if (inherits(x, "ts") && !is.null(ncol(x))) {
     # COLNAMES <- paste(colnames(x));
     tp.1 <- trunc(time(x))
@@ -229,27 +249,28 @@ xtable.ts <- function(x,caption=NULL,label=NULL,align=NULL,
     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
     ROWNAMES <- switch(frequency(x),
                        tp.1,
-                       "Arg2", "Arg3",              ## Dummy arguments
-                       paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep=" "),
+                       "Arg2", "Arg3",              # Dummy arguments
+                       paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
                        "Arg5", "Arg6",
-                       paste("Wk.", tp.1, " ", day.abb[tp.2], sep=""),
+                       paste("Wk.", tp.1, " ", day.abb[tp.2], sep = ""),
                        "Arg8", "Arg9", "Arg10", "Arg11",
-                       paste(tp.1, month.abb[tp.2], sep=" "))
-    tmp <- data.frame(x, row.names=ROWNAMES);
+                       paste(tp.1, month.abb[tp.2], sep = " "))
+    tmp <- data.frame(x, row.names = ROWNAMES);
   }
   else if (inherits(x, "ts") && is.null(ncol(x))) {
     COLNAMES <- switch(frequency(x),
                        "Value",
-                       "Arg2", "Arg3",              ## Dummy arguments
+                       "Arg2", "Arg3",              # Dummy arguments
                        c("Q1", "Q2", "Q3", "Q4"),
                        "Arg5", "Arg6",
                        day.abb,
                        "Arg8", "Arg9", "Arg10", "Arg11",
                        month.abb)
-    ROWNAMES <- seq(from=start(x)[1], to=end(x)[1])
+    ROWNAMES <- seq(from = start(x)[1], to = end(x)[1])
     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
                                rep(NA, frequency(x) - end(x)[2])),
-                             ncol=frequency(x), byrow=TRUE), row.names=ROWNAMES)
+                             ncol = frequency(x), byrow = TRUE),
+                      row.names = ROWNAMES)
     names(tmp) <- COLNAMES
   }
   return(xtable(tmp, caption = caption, label = label, align = align,
@@ -257,7 +278,7 @@ xtable.ts <- function(x,caption=NULL,label=NULL,align=NULL,
 }
 
 # Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
-xtable.zoo <- function(x,...) {
-  return(xtable(as.ts(x),...))
+xtable.zoo <- function(x, ...) {
+  return(xtable(as.ts(x), ...))
 }
 

diff --git a/pkg/tests/test.xtable.data.frame.R b/pkg/tests/test.xtable.data.frame.R
new file mode 100644 (file)
index 0000000..5abd95d
--- /dev/null
+++ b/pkg/tests/test.xtable.data.frame.R
@@ -0,0 +1,23 @@
+### Test code for logicals bug (number 1911)
+### David Scott, <d.scott@auckland.ac.nz>, 2012-08-10
+### Example of problem with logical
+library(xtable)
+mydf <- data.frame(x = c(1,2), y = c(TRUE,FALSE))
+xtable(mydf)
+
+### Output should be
+## % latex table generated in R 2.15.0 by xtable 1.7-0 package
+## % Fri Aug 10 23:16:30 2012
+## \begin{table}[ht]
+## \begin{center}
+## \begin{tabular}{rrl}
+##   \hline
+##  & x & y \\
+##   \hline
+## 1 & 1.00 & TRUE \\
+##   2 & 2.00 & FALSE \\
+##    \hline
+## \end{tabular}
+## \end{center}
+## \end{table}
+