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] <- lapply(x[,logicals], as.character)
  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 if (length(dim(x))==2) {
  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   } else {
  71     else stop("xtable.table is not implemented for tables of > 2 dimensions")
  72   }
  73 }
  74
  75
  76 ## anova objects
  77
  78 xtable.anova <- function(x,caption=NULL,label=NULL,align=NULL,
  79                          digits=NULL,display=NULL,...) {
  80   suggested.digits <- c(0,rep(2,ncol(x)))
  81   suggested.digits[grep("Pr\\(>",names(x))+1] <- 4
  82   suggested.digits[grep("P\\(>",names(x))+1] <- 4
  83   suggested.digits[grep("Df",names(x))+1] <- 0
  84
  85   class(x) <- c("xtable","data.frame")
  86   caption(x) <- caption
  87   label(x) <- label
  88   align(x) <- switch(1+is.null(align),align,c("l",rep("r",ncol(x))))
  89   digits(x) <- switch(1+is.null(digits),digits,suggested.digits)
  90   display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
  91   return(x)
  92 }
  93
  94
  95 ## aov objects
  96
  97 xtable.aov <- function(x,caption=NULL,label=NULL,align=NULL,
  98                        digits=NULL,display=NULL,...) {
  99   return(xtable.anova(anova(x,...),caption=caption,label=label,
 100                       align=align, digits=digits,display=display))
 101 }
 102
 103 xtable.summary.aov <- function(x,caption=NULL,label=NULL,align=NULL,
 104                                digits=NULL,display=NULL,...) {
 105   return(xtable.anova(x[[1]],caption=caption,label=label,
 106                       align=align, digits=digits,display=display))
 107 }
 108
 109 xtable.summary.aovlist <- function(x,caption=NULL,label=NULL,align=NULL,
 110                                    digits=NULL,display=NULL,...) {
 111   for(i in 1:length(x)) {
 112     if (i==1) result <- xtable.summary.aov(x[[i]],caption=caption,label=label,
 113           align=align, digits=digits,display=display)
 114     else result <- rbind(result,xtable.anova(x[[i]][[1]],caption=caption,
 115                                              label=label, align=align,
 116                                              digits=digits,display=display))
 117   }
 118   return(result)
 119 }
 120
 121 xtable.aovlist <- function(x,caption=NULL,label=NULL,align=NULL,
 122                            digits=NULL,display=NULL,...) {
 123   return(xtable.summary.aovlist(summary(x),caption=caption,label=label,
 124                                 align=align, digits=digits,display=display))
 125 }
 126
 127
 128
 129 ## lm objects
 130
 131 xtable.lm <- function(x,caption=NULL,label=NULL,align=NULL,
 132                       digits=NULL,display=NULL,...) {
 133   return(xtable.summary.lm(summary(x),caption=caption,label=label,
 134                            align=align, digits=digits,display=display))
 135 }
 136
 137 xtable.summary.lm <- function(x,caption=NULL,label=NULL,align=NULL,
 138                               digits=NULL,display=NULL,...) {
 139   x <- data.frame(x$coef,check.names=FALSE)
 140
 141   class(x) <- c("xtable","data.frame")
 142   caption(x) <- caption
 143   label(x) <- label
 144   align(x) <- switch(1+is.null(align),align,c("r","r","r","r","r"))
 145   digits(x) <- switch(1+is.null(digits),digits,c(0,4,4,2,4))
 146   display(x) <- switch(1+is.null(display),display,c("s","f","f","f","f"))
 147   return(x)
 148 }
 149
 150
 151 ## glm objects
 152
 153 xtable.glm <- function(x,caption=NULL,label=NULL,align=NULL,
 154                        digits=NULL,display=NULL,...) {
 155   return(xtable.summary.glm(summary(x),caption=caption,label=label,align=align,
 156                             digits=digits,display=display))
 157 }
 158
 159 xtable.summary.glm <- function(x,caption=NULL,label=NULL,align=NULL,
 160                                digits=NULL,display=NULL,...) {
 161   return(xtable.summary.lm(x,caption=caption,label=label,
 162                            align=align, digits=digits,display=display))
 163 }
 164
 165
 166 ## prcomp objects
 167
 168 xtable.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
 169                           digits=NULL,display=NULL,...) {
 170   x <- data.frame(x$rotation,check.names=FALSE)
 171
 172   class(x) <- c("xtable","data.frame")
 173   caption(x) <- caption
 174   label(x) <- label
 175   align(x) <- switch(1+is.null(align),align,c("r",rep("r",ncol(x))))
 176   digits(x) <- switch(1+is.null(digits),digits,c(0,rep(4,ncol(x))))
 177   display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
 178   return(x)
 179 }
 180
 181 xtable.summary.prcomp <- function(x,caption=NULL,label=NULL,align=NULL,
 182                                   digits=NULL,display=NULL,...) {
 183   x <- data.frame(x$importance,check.names=FALSE)
 184
 185   class(x) <- c("xtable","data.frame")
 186   caption(x) <- caption
 187   label(x) <- label
 188   align(x) <- switch(1+is.null(align),align,c("r",rep("r",ncol(x))))
 189   digits(x) <- switch(1+is.null(digits),digits,c(0,rep(4,ncol(x))))
 190   display(x) <- switch(1+is.null(display),display,c("s",rep("f",ncol(x))))
 191   return(x)
 192 }
 193
 194
 195 # Slightly modified version of xtable.coxph contributed on r-help by
 196 #   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 197 #   From: Jun Yan <jyan@stat.wisc.edu>
 198 #   Subject: Re: [R] xtable for Cox model output
 199 xtable.coxph <- function (x,caption=NULL,label=NULL,align=NULL,
 200                           digits=NULL,display=NULL,...)
 201 {
 202   cox <- x
 203   beta <- cox$coef
 204   se <- sqrt(diag(cox$var))
 205   if (is.null(cox$naive.var)) {
 206     tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
 207     dimnames(tmp) <- list(names(beta),
 208       c("coef", "exp(coef)", "se(coef)", "z", "p"))
 209   }
 210   else {
 211     tmp <- cbind( beta, exp(beta), se, beta/se,
 212       signif(1 - pchisq((beta/se)^2, 1), digits - 1))
 213     dimnames(tmp) <- list(names(beta),
 214       c("coef", "exp(coef)", "robust se", "z", "p"))
 215   }
 216   return(xtable(tmp, caption = caption, label = label, align = align,
 217                 digits = digits, display = display))
 218 }
 219
 220 # Additional method: xtable.ts
 221 # Contributed by David Mitchell (davidm@netspeed.com.au)
 222 # Date: July 2003
 223 xtable.ts <- function(x,caption=NULL,label=NULL,align=NULL,
 224                       digits=NULL,display=NULL,...) {
 225   if (inherits(x, "ts") && !is.null(ncol(x))) {
 226     # COLNAMES <- paste(colnames(x));
 227     tp.1 <- trunc(time(x))
 228     tp.2 <- trunc(cycle(x))
 229     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 230     ROWNAMES <- switch(frequency(x),
 231                        tp.1,
 232                        "Arg2", "Arg3",              ## Dummy arguments
 233                        paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep=" "),
 234                        "Arg5", "Arg6",
 235                        paste("Wk.", tp.1, " ", day.abb[tp.2], sep=""),
 236                        "Arg8", "Arg9", "Arg10", "Arg11",
 237                        paste(tp.1, month.abb[tp.2], sep=" "))
 238     tmp <- data.frame(x, row.names=ROWNAMES);
 239   }
 240   else if (inherits(x, "ts") && is.null(ncol(x))) {
 241     COLNAMES <- switch(frequency(x),
 242                        "Value",
 243                        "Arg2", "Arg3",              ## Dummy arguments
 244                        c("Q1", "Q2", "Q3", "Q4"),
 245                        "Arg5", "Arg6",
 246                        day.abb,
 247                        "Arg8", "Arg9", "Arg10", "Arg11",
 248                        month.abb)
 249     ROWNAMES <- seq(from=start(x)[1], to=end(x)[1])
 250     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
 251                                rep(NA, frequency(x) - end(x)[2])),
 252                              ncol=frequency(x), byrow=TRUE), row.names=ROWNAMES)
 253     names(tmp) <- COLNAMES
 254   }
 255   return(xtable(tmp, caption = caption, label = label, align = align,
 256                 digits = digits, display = display))
 257 }
 258
 259 # Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
 260 xtable.zoo <- function(x,...) {
 261   return(xtable(as.ts(x),...))
 262 }
 263