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, auto = FALSE, ...) {
  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, auto = FALSE,
  33                               ...) {
  34   logicals <- unlist(lapply(x, is.logical))
  35   ##x[, logicals] <- lapply(x[, logicals], as.character)
  36   ## Patch for logicals bug, no 1911
  37   ## David Scott, <d.scott@auckland.ac.nz>, 2012-08-10
  38   x[, logicals] <- lapply(x[, logicals, drop = FALSE], as.character)
  39   characters <- unlist(lapply(x, is.character))
  40   factors <- unlist(lapply(x, is.factor))
  41   ints <- sapply(x, is.integer)
  42   class(x) <- c("xtable","data.frame")
  43   caption(x) <- caption
  44   label(x) <- label
  45   if(auto && is.null(align))   align   <- xalign(x)
  46   if(auto && is.null(digits))  digits  <- xdigits(x)
  47   if(auto && is.null(display)) display <- xdisplay(x)
  48   align(x) <- switch(1+is.null(align), align,
  49                      c("r",c("r","l")[(characters|factors)+1]))
  50   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(2,ncol(x))))
  51   ## Patch from Seth Falcon <sfalcon@fhcrc.org>, 18-May-2007
  52   if (is.null(display)) {
  53       display <- rep("f", ncol(x))
  54       display[ints] <- "d"
  55       display[characters | factors] <- "s"
  56       display <- c("s", display)
  57   }
  58   display(x) <- display
  59   return(x)
  60 }
  61
  62 xtable.matrix <- function(x, caption = NULL, label = NULL, align = NULL,
  63                           digits = NULL, display = NULL, auto = FALSE, ...) {
  64   return(xtable.data.frame(data.frame(x, check.names = FALSE),
  65                            caption = caption, label = label, align = align,
  66                            digits = digits, display = display, auto = auto,
  67                            ...))
  68 }
  69
  70
  71
  72 ### table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
  73 ### Fixed to pass R checks by DBD, 9 May 2007
  74 xtable.table <- function(x, caption = NULL, label = NULL, align = NULL,
  75                        digits = NULL, display = NULL, auto = FALSE, ...) {
  76   if (length(dim(x)) == 1) {
  77     return(xtable.matrix(matrix(x,
  78                                 dimnames = list(rownames(x),
  79                                                 names(dimnames(x)))),
  80                          caption = caption, label = label, align = align,
  81                          digits = digits, display = display, auto = auto))
  82   } else if (length(dim(x))==2) {
  83     return(xtable.matrix(matrix(x, ncol = dim(x)[2], nrow = dim(x)[1],
  84                                 dimnames = list(rownames(x), colnames(x))),
  85                          caption = caption, label = label, align = align,
  86                          digits = digits, display = display, auto = auto))
  87   } else {
  88     stop("xtable.table is not implemented for tables of > 2 dimensions")
  89   }
  90 }
  91
  92
  93 ### anova objects
  94
  95 xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
  96                          digits = NULL, display = NULL, auto = FALSE, ...) {
  97   suggested.digits <- c(0,rep(2, ncol(x)))
  98   suggested.digits[grep("Pr\\(>", names(x))+1] <- 4
  99   suggested.digits[grep("P\\(>", names(x))+1] <- 4
 100   suggested.digits[grep("Df", names(x))+1] <- 0
 101
 102   class(x) <- c("xtable","data.frame")
 103   caption(x) <- caption
 104   label(x) <- label
 105   if(auto && is.null(align))   align   <- xalign(x)
 106   if(auto && is.null(digits))  digits  <- xdigits(x)
 107   if(auto && is.null(display)) display <- xdisplay(x)
 108   align(x) <- switch(1+is.null(align), align, c("l",rep("r", ncol(x))))
 109   digits(x) <- switch(1+is.null(digits), digits, suggested.digits)
 110   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 111   return(x)
 112 }
 113
 114
 115 ### aov objects
 116
 117 xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 118                        digits = NULL, display = NULL, auto = FALSE, ...) {
 119   return(xtable.anova(anova(x, ...), caption = caption, label = label,
 120                       align = align, digits = digits, display = display,
 121                       auto = auto))
 122 }
 123
 124 xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 125                                digits = NULL, display = NULL, auto = FALSE,
 126                                ...) {
 127   return(xtable.anova(x[[1]], caption = caption, label = label, align = align,
 128                       digits = digits, display = display, auto = auto))
 129 }
 130
 131 xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
 132                                    align = NULL, digits = NULL, display = NULL,
 133                                    auto = FALSE, ...) {
 134     for (i in 1:length(x)) {
 135         if (i == 1) {
 136             result <- xtable.summary.aov(x[[i]], caption = caption,
 137                                          label = label,
 138                                          align = align, digits = digits,
 139                                          display = display, auto = auto)
 140         } else {
 141             result <- rbind(result,
 142                             xtable.anova(x[[i]][[1]], caption = caption,
 143                                          label = label, align = align,
 144                                          digits = digits, display = display,
 145                                          auto = auto))
 146         }
 147     }
 148     return(result)
 149 }
 150
 151 xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
 152                            digits = NULL, display = NULL, auto = FALSE, ...) {
 153   return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
 154                                 align = align, digits = digits,
 155                                 display = display, auto = auto))
 156 }
 157
 158
 159
 160 ### lm objects
 161
 162 xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 163                       digits = NULL, display = NULL, auto = FALSE, ...) {
 164   return(xtable.summary.lm(summary(x), caption = caption, label = label,
 165                            align = align, digits = digits, display = display,
 166                            auto = auto))
 167 }
 168
 169 xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 170                               digits = NULL, display = NULL, auto = FALSE,
 171                               ...) {
 172   x <- data.frame(x$coef, check.names = FALSE)
 173
 174   class(x) <- c("xtable","data.frame")
 175   caption(x) <- caption
 176   label(x) <- label
 177   if(auto && is.null(align))   align   <- xalign(x)
 178   if(auto && is.null(digits))  digits  <- xdigits(x)
 179   if(auto && is.null(display)) display <- xdisplay(x)
 180   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 181   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 182   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 183   return(x)
 184 }
 185
 186
 187 ### glm objects
 188
 189 xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 190                        digits = NULL, display = NULL, auto = FALSE, ...) {
 191   return(xtable.summary.glm(summary(x), caption = caption,
 192                             label = label, align = align,
 193                             digits = digits, display = display, auto = auto))
 194 }
 195
 196 xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 197                                digits = NULL, display = NULL, auto = FALSE,
 198                                ...) {
 199   return(xtable.summary.lm(x, caption = caption, label = label, align = align,
 200                            digits = digits, display = display, auto = auto))
 201 }
 202
 203
 204 ### prcomp objects
 205
 206 xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 207                           digits = NULL, display = NULL, auto = FALSE, ...) {
 208   x <- data.frame(x$rotation, check.names = FALSE)
 209
 210   class(x) <- c("xtable","data.frame")
 211   caption(x) <- caption
 212   label(x) <- label
 213   if(auto && is.null(align))   align   <- xalign(x)
 214   if(auto && is.null(digits))  digits  <- xdigits(x)
 215   if(auto && is.null(display)) display <- xdisplay(x)
 216   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 217   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 218   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 219   return(x)
 220 }
 221
 222 xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 223                                   digits = NULL, display = NULL, auto = FALSE,
 224                                   ...) {
 225   x <- data.frame(x$importance, check.names = FALSE)
 226
 227   class(x) <- c("xtable","data.frame")
 228   caption(x) <- caption
 229   label(x) <- label
 230   if(auto && is.null(align))   align   <- xalign(x)
 231   if(auto && is.null(digits))  digits  <- xdigits(x)
 232   if(auto && is.null(display)) display <- xdisplay(x)
 233   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 234   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 235   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 236   return(x)
 237 }
 238
 239
 240 # Slightly modified version of xtable.coxph contributed on r-help by
 241 #   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 242 #   From: Jun Yan <jyan@stat.wisc.edu>
 243 #   Subject: Re: [R] xtable for Cox model output
 244 xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
 245                           digits = NULL, display = NULL, auto = FALSE, ...)
 246 {
 247   cox <- x
 248   beta <- cox$coef
 249   se <- sqrt(diag(cox$var))
 250   if (is.null(cox$naive.var)) {
 251     tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
 252     dimnames(tmp) <- list(names(beta),
 253       c("coef", "exp(coef)", "se(coef)", "z", "p"))
 254   } else {
 255     tmp <- cbind( beta, exp(beta), se, beta/se,
 256       signif(1 - pchisq((beta/se)^2, 1), digits - 1))
 257     dimnames(tmp) <- list(names(beta),
 258       c("coef", "exp(coef)", "robust se", "z", "p"))
 259   }
 260   return(xtable(tmp, caption = caption, label = label, align = align,
 261                 digits = digits, display = display, auto = auto))
 262 }
 263
 264 # Additional method: xtable.ts
 265 # Contributed by David Mitchell (davidm@netspeed.com.au)
 266 # Date: July 2003
 267 xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
 268                       digits = NULL, display = NULL, auto = FALSE, ...) {
 269   if (inherits(x, "ts") && !is.null(ncol(x))) {
 270     # COLNAMES <- paste(colnames(x));
 271     tp.1 <- trunc(time(x))
 272     tp.2 <- trunc(cycle(x))
 273     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 274     ROWNAMES <- switch(frequency(x),
 275                        tp.1,
 276                        "Arg2", "Arg3",              # Dummy arguments
 277                        paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
 278                        "Arg5", "Arg6",
 279                        paste("Wk.", tp.1, " ", day.abb[tp.2], sep = ""),
 280                        "Arg8", "Arg9", "Arg10", "Arg11",
 281                        paste(tp.1, month.abb[tp.2], sep = " "))
 282     tmp <- data.frame(x, row.names = ROWNAMES);
 283   } else if (inherits(x, "ts") && is.null(ncol(x))) {
 284     COLNAMES <- switch(frequency(x),
 285                        "Value",
 286                        "Arg2", "Arg3",              # Dummy arguments
 287                        c("Q1", "Q2", "Q3", "Q4"),
 288                        "Arg5", "Arg6",
 289                        day.abb,
 290                        "Arg8", "Arg9", "Arg10", "Arg11",
 291                        month.abb)
 292     ROWNAMES <- seq(from = start(x)[1], to = end(x)[1])
 293     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
 294                                rep(NA, frequency(x) - end(x)[2])),
 295                              ncol = frequency(x), byrow = TRUE),
 296                       row.names = ROWNAMES)
 297     names(tmp) <- COLNAMES
 298   }
 299   return(xtable(tmp, caption = caption, label = label, align = align,
 300                 digits = digits, display = display, auto = auto))
 301 }
 302
 303 ### Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
 304 xtable.zoo <- function(x, ...) {
 305   return(xtable(as.ts(x), ...))
 306 }
 307
 308
 309 ### package spdep
 310 ### sarlm objects
 311 xtable.sarlm <- function(x, caption = NULL, label = NULL, align = NULL,
 312                          digits = NULL, display = NULL, auto = FALSE, ...) {
 313   return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 314                               align = align, digits = digits,
 315                               display = display, auto = auto))
 316 }
 317
 318 xtable.summary.sarlm <- function(x, caption = NULL, label = NULL, align = NULL,
 319                                 digits = NULL, display = NULL, auto = FALSE,
 320                                 ...) {
 321   x <- data.frame(x$Coef, check.names = FALSE)
 322
 323   class(x) <- c("xtable","data.frame")
 324   caption(x) <- caption
 325   label(x) <- label
 326   if(auto && is.null(align))   align   <- xalign(x)
 327   if(auto && is.null(digits))  digits  <- xdigits(x)
 328   if(auto && is.null(display)) display <- xdisplay(x)
 329   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 330   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 331   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 332   return(x)
 333 }
 334
 335 ### gmsar objects
 336 xtable.gmsar <- function(x, caption = NULL, label = NULL, align = NULL,
 337                          digits = NULL, display = NULL, auto = FALSE, ...) {
 338   return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 339                               align = align, digits = digits,
 340                               display = display, auto = auto))
 341 }
 342
 343 xtable.summary.gmsar <- function(x, caption = NULL, label = NULL, align = NULL,
 344                                  digits = NULL, display = NULL,
 345                                  auto = FALSE, ...) {
 346   return(xtable.summary.sarlm(x, caption = caption, label = label,
 347                               align = align, digits = digits,
 348                               display = display, auto = auto))
 349 }
 350
 351 ### stsls objects
 352 xtable.stsls <- function(x, caption = NULL, label = NULL, align = NULL,
 353                          digits = NULL, display = NULL, auto = FALSE, ...) {
 354   return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 355                               align = align, digits = digits,
 356                               display = display, auto = auto))
 357 }
 358
 359 xtable.summary.stsls <- function(x, caption = NULL, label = NULL, align = NULL,
 360                                  digits = NULL, display = NULL,
 361                                  auto = FALSE, ...) {
 362   return(xtable.summary.sarlm(x, caption = caption, label = label,
 363                               align = align, digits = digits,
 364                               display = display, auto = auto))
 365 }
 366
 367
 368 ### package splm
 369 ### splm objects
 370 xtable.splm <- function(x, caption = NULL, label = NULL, align = NULL,
 371                         digits = NULL, display = NULL, auto = FALSE, ...) {
 372   return(xtable.summary.splm(summary(x), caption = caption, label = label,
 373                              align = align, digits = digits,
 374                              display = display, auto = auto))
 375 }
 376
 377 xtable.summary.splm <- function(x, caption = NULL, label = NULL, align = NULL,
 378                                 digits = NULL, display = NULL, auto = FALSE,
 379                                 ...) {
 380   x <- data.frame(x$CoefTable, check.names = FALSE)
 381
 382   class(x) <- c("xtable","data.frame")
 383   caption(x) <- caption
 384   label(x) <- label
 385   if(auto && is.null(align))   align   <- xalign(x)
 386   if(auto && is.null(digits))  digits  <- xdigits(x)
 387   if(auto && is.null(display)) display <- xdisplay(x)
 388   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 389   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 390   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 391   return(x)
 392 }
 393
 394 ### package sphet
 395 ### sphet objects
 396 xtable.sphet <- function(x, caption = NULL, label = NULL, align = NULL,
 397                          digits = NULL, display = NULL, auto = FALSE, ...) {
 398   return(xtable.summary.splm(summary(x), caption = caption, label = label,
 399                              align = align, digits = digits,
 400                              display = display, auto = auto))
 401 }
 402
 403 xtable.summary.sphet <- function(x, caption = NULL, label = NULL, align = NULL,
 404                                  digits = NULL, display = NULL,
 405                                  auto = FALSE, ...) {
 406   return(xtable.summary.splm(x, caption = caption, label = label,
 407                              align = align, digits = digits,
 408                              display = display, auto = auto))
 409 }