From: dscott Date: Fri, 10 Aug 2012 11:39:40 +0000 (+0000) Subject: fixed logicals bug (number 1911) X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=1e87cb3f3eeb872898ac744ac838b86e72b2437e;p=xtable.git 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 463f0df..ae32544 100644 --- 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 Maintainer: Charles Roosen diff --git a/pkg/NEWS b/pkg/NEWS index 5f5356d..47537ba 100644 --- 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 d6bc227..6c65954 100644 --- 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, , 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 , 18-May-2007 + digits(x) <- switch(1+is.null(digits), digits, c(0,rep(2,ncol(x)))) + ## Patch from Seth Falcon , 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 # 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 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 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, , 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} +