pkg/R/xtable.R

   1 ### xtable package
   2 ###
   3 ### Produce LaTeX and HTML tables from R objects.
   4 ###
   5 ### Copyright 2000-2007 David B. Dahl <dahl@stat.tamu.edu>
   6 ###
   7 ### This file is part of the `xtable' library for R and related languages.
   8 ### It is made available under the terms of the GNU General Public
   9 ### License, version 2, or at your option, any later version,
  10 ### incorporated herein by reference.
  11 ###
  12 ### This program is distributed in the hope that it will be
  13 ### useful, but WITHOUT ANY WARRANTY; without even the implied
  14 ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15 ### PURPOSE.  See the GNU General Public License for more
  16 ### details.
  17 ###
  18 ### You should have received a copy of the GNU General Public
  19 ### License along with this program; if not, write to the Free
  20 ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21 ### MA 02111-1307, USA
  22
  23 xtable <- function(x,caption=NULL,label=NULL,align=NULL,
  24                    digits=NULL,display=NULL,...) {
  25   UseMethod("xtable")
  26 }
  27
  28
  29 ## data.frame and matrix objects
  30
  31 xtable.data.frame <- function(x,caption=NULL,label=NULL,align=NULL,
  32                               digits=NULL,display=NULL,...) {
  33   logicals <- unlist(lapply(x,is.logical))
  34   x[,logicals] <- as.character(x[,logicals])
  35   characters <- unlist(lapply(x,is.character))
  36   factors <- unlist(lapply(x,is.factor))
  37   ints <- sapply(x, is.integer)
  38   class(x) <- c("xtable","data.frame")
  39   caption(x) <- caption
  40   label(x) <- label
  41   align(x) <- switch(1+is.null(align), align,
  42                      c("r",c("r","l")[(characters|factors)+1]))
  43   digits(x) <- switch(1+is.null(digits),digits,c(0,rep(2,ncol(x))))
  44   # Patch from Seth Falcon <sfalcon@fhcrc.org>, 18-May-2007
  45   if (is.null(display)) {
  46       display <- rep("f", ncol(x))
  47       display[ints] <- "d"
  48       display[characters | factors] <- "s"
  49       display <- c("s", display)
  50   }
  51   display(x) <- display
  52   return(x)
  53 }
  54
  55 xtable.matrix <- function(x,caption=NULL,label=NULL,align=NULL,
  56                           digits=NULL,display=NULL,...) {
  57   return(xtable.data.frame(data.frame(x,check.names=FALSE),
  58                            caption=caption,label=label,align=align,
  59                            digits=digits,display=display))
  60 }
  61
  62
  63 ## table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
  64 ## Fixed to pass R checks by DBD, 9 May 2007
  65 xtable.table<-function(x,caption=NULL,label=NULL,align=NULL, digits=NULL,display=NULL,...) {
  66   if (length(dim(x))==1) {
  67     return(xtable.matrix(matrix(x,dimnames=list(rownames(x),names(dimnames(x)))),caption=caption,label=label,align=align,digits=digits,display=display))
  68   } else {
  69     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))
  70   }
  71 }
  72
  73
  74 ## anova objects
  75
  76 xtable.anova <- function(x,caption=NULL,label=NULL,align=NULL,
  77                          digits=NULL,display=NULL,...) {
  78   suggested.digits <- c(0,rep(2,ncol(x)))
  79   suggested.digits[grep("Pr\\(>",names(x))+1] <- 4
  80   suggested.digits[grep("P\\(>",names(x))+1] <- 4
  81   suggested.digits[grep("Df",names(x))+1] <- 0
  82
  83   class(x) <- c("xtable","data.frame")
  84   caption(x) <- caption
  85   label(x) <- label
  86   align(x) <- switch(1+is.null(align),align,c("l",rep("r",ncol(x))))
  87   digits(x) <- switch(1+is.null(digits),digits,suggested.digits)
  88   display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
  89   return(x)
  90 }
  91
  92
  93 ## aov objects
  94
  95 xtable.aov <- function(x,caption=NULL,label=NULL,align=NULL,
  96                        digits=NULL,display=NULL,...) {
  97   return(xtable.anova(anova(x,...),caption=caption,label=label,
  98                       align=align, digits=digits,display=display))
  99 }
 100
 101 xtable.summary.aov <- function(x,caption=NULL,label=NULL,align=NULL,
 102                                digits=NULL,display=NULL,...) {
 103   return(xtable.anova(x[[1]],caption=caption,label=label,
 104                       align=align, digits=digits,display=display))
 105 }
 106
 107 xtable.summary.aovlist <- function(x,caption=NULL,label=NULL,align=NULL,
 108                                    digits=NULL,display=NULL,...) {
 109   for(i in 1:length(x)) {
 110     if (i==1) result <- xtable.summary.aov(x[[i]],caption=caption,label=label,
 111           align=align, digits=digits,display=display)
 112     else result <- rbind(result,xtable.anova(x[[i]][[1]],caption=caption,
 113                                              label=label, align=align,
 114                                              digits=digits,display=display))
 115   }
 116   return(result)
 117 }
 118
 119 xtable.aovlist <- function(x,caption=NULL,label=NULL,align=NULL,
 120                            digits=NULL,display=NULL,...) {
 121   return(xtable.summary.aovlist(summary(x),caption=caption,label=label,
 122                                 align=align, digits=digits,display=display))
 123 }
 124
 125
 126
 127 ## lm objects
 128
 129 xtable.lm <- function(x,caption=NULL,label=NULL,align=NULL,
 130                       digits=NULL,display=NULL,...) {
 131   return(xtable.summary.lm(summary(x),caption=caption,label=label,
 132                            align=align, digits=digits,display=display))
 133 }
 134
 135 xtable.summary.lm <- function(x,caption=NULL,label=NULL,align=NULL,
 136                               digits=NULL,display=NULL,...) {
 137   x <- data.frame(x$coef,check.names=FALSE)
 138
 139   class(x) <- c("xtable","data.frame")
 140   caption(x) <- caption
 141   label(x) <- label
 142   align(x) <- switch(1+is.null(align),align,c("r","r","r","r","r"))
 143   digits(x) <- switch(1+is.null(digits),digits,c(0,4,4,2,4))
 144   display(x) <- switch(1+is.null(display),display,c("s","f","f","f","f"))
 145   return(x)
 146 }
 147
 148
 149 ## glm objects
 150
 151 xtable.glm <- function(x,caption=NULL,label=NULL,align=NULL,
 152                        digits=NULL,display=NULL,...) {
 153   return(xtable.summary.glm(summary(x),caption=caption,label=label,align=align,
 154                             digits=digits,display=display))
 155 }
 156
 157 xtable.summary.glm <- function(x,caption=NULL,label=NULL,align=NULL,
 158                                digits=NULL,display=NULL,...) {
 159   return(xtable.summary.lm(x,caption=caption,label=label,
 160                            align=align, digits=digits,display=display))
 161 }
 162
 163
 164 ## prcomp objects
 165
 166 xtable.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
 167                           digits=NULL,display=NULL,...) {
 168   x <- data.frame(x$rotation,check.names=FALSE)
 169
 170   class(x) <- c("xtable","data.frame")
 171   caption(x) <- caption
 172   label(x) <- label
 173   align(x) <- switch(1+is.null(align),align,c("r",rep("r",ncol(x))))
 174   digits(x) <- switch(1+is.null(digits),digits,c(0,rep(4,ncol(x))))
 175   display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
 176   return(x)
 177 }
 178
 179 xtable.summary.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
 180                                   digits=NULL,display=NULL,...) {
 181   x <- data.frame(x$importance,check.names=FALSE)
 182
 183   class(x) <- c("xtable","data.frame")
 184   caption(x) <- caption
 185   label(x) <- label
 186   align(x) <- switch(1+is.null(align),align,c("r",rep("r",ncol(x))))
 187   digits(x) <- switch(1+is.null(digits),digits,c(0,rep(4,ncol(x))))
 188   display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
 189   return(x)
 190 }
 191
 192
 193 # Slightly modified version of xtable.coxph contributed on r-help by
 194 #   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 195 #   From: Jun Yan <jyan@stat.wisc.edu>
 196 #   Subject: Re: [R] xtable for Cox model output
 197 xtable.coxph <- function (x,caption=NULL,label=NULL,align=NULL,
 198                           digits=NULL,display=NULL,...)
 199 {
 200   cox <- x
 201   beta <- cox$coef
 202   se <- sqrt(diag(cox$var))
 203   if (is.null(cox$naive.var)) {
 204     tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
 205     dimnames(tmp) <- list(names(beta),
 206       c("coef", "exp(coef)", "se(coef)", "z", "p"))
 207   }
 208   else {
 209     tmp <- cbind( beta, exp(beta), se, beta/se,
 210       signif(1 - pchisq((beta/se)^2, 1), digits - 1))
 211     dimnames(tmp) <- list(names(beta),
 212       c("coef", "exp(coef)", "robust se", "z", "p"))
 213   }
 214   return(xtable(tmp, caption = caption, label = label, align = align,
 215                 digits = digits, display = display))
 216 }
 217
 218 # Additional method: xtable.ts
 219 # Contributed by David Mitchell (davidm@netspeed.com.au)
 220 # Date: July 2003
 221 xtable.ts <- function(x,caption=NULL,label=NULL,align=NULL,
 222                       digits=NULL,display=NULL,...) {
 223   if (inherits(x, "ts") && !is.null(ncol(x))) {
 224     # COLNAMES <- paste(colnames(x));
 225     tp.1 <- trunc(time(x))
 226     tp.2 <- trunc(cycle(x))
 227     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 228     ROWNAMES <- switch(frequency(x),
 229                        tp.1,
 230                        "Arg2", "Arg3",              ## Dummy arguments
 231                        paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep=" "),
 232                        "Arg5", "Arg6",
 233                        paste("Wk.", tp.1, " ", day.abb[tp.2], sep=""),
 234                        "Arg8", "Arg9", "Arg10", "Arg11",
 235                        paste(tp.1, month.abb[tp.2], sep=" "))
 236     tmp <- data.frame(x, row.names=ROWNAMES);
 237   }
 238   else if (inherits(x, "ts") && is.null(ncol(x))) {
 239     COLNAMES <- switch(frequency(x),
 240                        "Value",
 241                        "Arg2", "Arg3",              ## Dummy arguments
 242                        c("Q1", "Q2", "Q3", "Q4"),
 243                        "Arg5", "Arg6",
 244                        day.abb,
 245                        "Arg8", "Arg9", "Arg10", "Arg11",
 246                        month.abb)
 247     ROWNAMES <- seq(from=start(x)[1], to=end(x)[1])
 248     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
 249                                rep(NA, frequency(x) - end(x)[2])),
 250                              ncol=frequency(x), byrow=TRUE), row.names=ROWNAMES)
 251     names(tmp) <- COLNAMES
 252   }
 253   return(xtable(tmp, caption = caption, label = label, align = align,
 254                 digits = digits, display = display))
 255 }
 256
 257 # Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
 258 xtable.zoo <- function(x,...) {
 259   return(xtable(as.ts(x),...))
 260 }
 261