pkg/R/xtable.R

   1 ### xtable package
   2 ###
   3 ### Produce LaTeX and HTML tables from R objects.
   4 ###
   5 ### Copyright 2000-2013 David B. Dahl <dahl@stat.byu.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   ## Patch for logicals bug, no 1911
  36   ## David Scott, <d.scott@auckland.ac.nz>, 2012-08-10
  37   x[, logicals] <- lapply(x[, logicals, drop = FALSE], as.character)
  38   characters <- unlist(lapply(x, is.character))
  39   factors <- unlist(lapply(x, is.factor))
  40   ints <- sapply(x, is.integer)
  41   class(x) <- c("xtable","data.frame")
  42   caption(x) <- caption
  43   label(x) <- label
  44   align(x) <- switch(1+is.null(align), align,
  45                      c("r",c("r","l")[(characters|factors)+1]))
  46   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(2,ncol(x))))
  47   ## Patch from Seth Falcon <sfalcon@fhcrc.org>, 18-May-2007
  48   if (is.null(display)) {
  49       display <- rep("f", ncol(x))
  50       display[ints] <- "d"
  51       display[characters | factors] <- "s"
  52       display <- c("s", display)
  53   }
  54   display(x) <- display
  55   return(x)
  56 }
  57
  58 xtable.matrix <- function(x, caption = NULL, label = NULL, align = NULL,
  59                           digits = NULL, display = NULL, ...) {
  60   return(xtable.data.frame(data.frame(x, check.names = FALSE),
  61                            caption = caption, label = label, align = align,
  62                            digits = digits, display = display))
  63 }
  64
  65
  66 ### table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
  67 ### Fixed to pass R checks by DBD, 9 May 2007
  68 xtable.table <- function(x, caption = NULL, label = NULL, align = NULL,
  69                        digits = NULL, display = NULL, ...) {
  70   if (length(dim(x)) == 1) {
  71     return(xtable.matrix(matrix(x,
  72                                 dimnames = list(rownames(x),
  73                                                 names(dimnames(x)))),
  74                          caption = caption, label = label,
  75                          align = align, digits = digits, display = display))
  76   } else if (length(dim(x))==2) {
  77     return(xtable.matrix(matrix(x, ncol = dim(x)[2], nrow = dim(x)[1],
  78                                 dimnames = list(rownames(x), colnames(x))),
  79                          caption = caption, label = label,
  80                          align = align, digits = digits, display = display))
  81   } else {
  82     stop("xtable.table is not implemented for tables of > 2 dimensions")
  83   }
  84 }
  85
  86
  87 ## anova objects
  88
  89 xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
  90                          digits = NULL, display = NULL, ...) {
  91   suggested.digits <- c(0,rep(2, ncol(x)))
  92   suggested.digits[grep("Pr\\(>", names(x))+1] <- 4
  93   suggested.digits[grep("P\\(>", names(x))+1] <- 4
  94   suggested.digits[grep("Df", names(x))+1] <- 0
  95
  96   class(x) <- c("xtable","data.frame")
  97   caption(x) <- caption
  98   label(x) <- label
  99   align(x) <- switch(1+is.null(align), align, c("l",rep("r", ncol(x))))
 100   digits(x) <- switch(1+is.null(digits), digits, suggested.digits)
 101   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 102   return(x)
 103 }
 104
 105
 106 ## aov objects
 107
 108 xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 109                        digits = NULL, display = NULL, ...) {
 110   return(xtable.anova(anova(x, ...), caption = caption, label = label,
 111                       align = align, digits = digits, display = display))
 112 }
 113
 114 xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 115                                digits = NULL, display = NULL, ...) {
 116   return(xtable.anova(x[[1]], caption = caption, label = label,
 117                       align = align, digits = digits, display = display))
 118 }
 119
 120 xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
 121                                    align = NULL,
 122                                    digits = NULL, display = NULL, ...) {
 123     for (i in 1:length(x)) {
 124         if (i == 1) {
 125             result <- xtable.summary.aov(x[[i]], caption = caption,
 126                                          label = label,
 127                                          align = align, digits = digits,
 128                                          display = display)
 129         } else {
 130             result <- rbind(result,
 131                             xtable.anova(x[[i]][[1]], caption = caption,
 132                                          label = label, align = align,
 133                                          digits = digits, display = display))
 134         }
 135     }
 136     return(result)
 137 }
 138
 139 xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
 140                            digits = NULL, display = NULL, ...) {
 141   return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
 142                                 align = align, digits = digits,
 143                                 display = display))
 144 }
 145
 146
 147
 148 ## lm objects
 149
 150 xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 151                       digits = NULL, display = NULL, ...) {
 152   return(xtable.summary.lm(summary(x), caption = caption, label = label,
 153                            align = align, digits = digits, display = display))
 154 }
 155
 156 xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 157                               digits = NULL, display = NULL, ...) {
 158   x <- data.frame(x$coef, check.names = FALSE)
 159
 160   class(x) <- c("xtable","data.frame")
 161   caption(x) <- caption
 162   label(x) <- label
 163   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 164   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 165   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 166   return(x)
 167 }
 168
 169
 170 ## glm objects
 171
 172 xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 173                        digits = NULL, display = NULL, ...) {
 174   return(xtable.summary.glm(summary(x), caption = caption,
 175                             label = label, align = align,
 176                             digits = digits, display = display))
 177 }
 178
 179 xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 180                                digits = NULL, display = NULL, ...) {
 181   return(xtable.summary.lm(x, caption = caption, label = label,
 182                            align = align, digits = digits, display = display))
 183 }
 184
 185
 186 ## prcomp objects
 187
 188 xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 189                           digits = NULL, display = NULL, ...) {
 190   x <- data.frame(x$rotation, check.names = FALSE)
 191
 192   class(x) <- c("xtable","data.frame")
 193   caption(x) <- caption
 194   label(x) <- label
 195   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 196   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 197   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 198   return(x)
 199 }
 200
 201 xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 202                                   digits = NULL, display = NULL, ...) {
 203   x <- data.frame(x$importance, check.names = FALSE)
 204
 205   class(x) <- c("xtable","data.frame")
 206   caption(x) <- caption
 207   label(x) <- label
 208   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 209   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 210   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 211   return(x)
 212 }
 213
 214
 215 # Slightly modified version of xtable.coxph contributed on r-help by
 216 #   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 217 #   From: Jun Yan <jyan@stat.wisc.edu>
 218 #   Subject: Re: [R] xtable for Cox model output
 219 xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
 220                           digits = NULL, display = NULL, ...)
 221 {
 222   cox <- x
 223   beta <- cox$coef
 224   se <- sqrt(diag(cox$var))
 225   if (is.null(cox$naive.var)) {
 226     tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
 227     dimnames(tmp) <- list(names(beta),
 228       c("coef", "exp(coef)", "se(coef)", "z", "p"))
 229   }
 230   else {
 231     tmp <- cbind( beta, exp(beta), se, beta/se,
 232       signif(1 - pchisq((beta/se)^2, 1), digits - 1))
 233     dimnames(tmp) <- list(names(beta),
 234       c("coef", "exp(coef)", "robust se", "z", "p"))
 235   }
 236   return(xtable(tmp, caption = caption, label = label, align = align,
 237                 digits = digits, display = display))
 238 }
 239
 240 # Additional method: xtable.ts
 241 # Contributed by David Mitchell (davidm@netspeed.com.au)
 242 # Date: July 2003
 243 xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
 244                       digits = NULL, display = NULL, ...) {
 245   if (inherits(x, "ts") && !is.null(ncol(x))) {
 246     # COLNAMES <- paste(colnames(x));
 247     tp.1 <- trunc(time(x))
 248     tp.2 <- trunc(cycle(x))
 249     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 250     ROWNAMES <- switch(frequency(x),
 251                        tp.1,
 252                        "Arg2", "Arg3",              # Dummy arguments
 253                        paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
 254                        "Arg5", "Arg6",
 255                        paste("Wk.", tp.1, " ", day.abb[tp.2], sep = ""),
 256                        "Arg8", "Arg9", "Arg10", "Arg11",
 257                        paste(tp.1, month.abb[tp.2], sep = " "))
 258     tmp <- data.frame(x, row.names = ROWNAMES);
 259   }
 260   else if (inherits(x, "ts") && is.null(ncol(x))) {
 261     COLNAMES <- switch(frequency(x),
 262                        "Value",
 263                        "Arg2", "Arg3",              # Dummy arguments
 264                        c("Q1", "Q2", "Q3", "Q4"),
 265                        "Arg5", "Arg6",
 266                        day.abb,
 267                        "Arg8", "Arg9", "Arg10", "Arg11",
 268                        month.abb)
 269     ROWNAMES <- seq(from = start(x)[1], to = end(x)[1])
 270     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
 271                                rep(NA, frequency(x) - end(x)[2])),
 272                              ncol = frequency(x), byrow = TRUE),
 273                       row.names = ROWNAMES)
 274     names(tmp) <- COLNAMES
 275   }
 276   return(xtable(tmp, caption = caption, label = label, align = align,
 277                 digits = digits, display = display))
 278 }
 279
 280 # Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
 281 xtable.zoo <- function(x, ...) {
 282   return(xtable(as.ts(x), ...))
 283 }
 284