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 xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
  95                          digits = NULL, display = NULL, auto = FALSE, ...) {
  96   suggested.digits <- c(0,rep(2, ncol(x)))
  97   suggested.digits[grep("Pr\\(>", names(x))+1] <- 4
  98   suggested.digits[grep("P\\(>", names(x))+1] <- 4
  99   suggested.digits[grep("Df", names(x))+1] <- 0
 100
 101   class(x) <- c("xtable","data.frame")
 102   caption(x) <- caption
 103   label(x) <- label
 104   if(auto && is.null(align))   align   <- xalign(x)
 105   if(auto && is.null(digits))  digits  <- xdigits(x)
 106   if(auto && is.null(display)) display <- xdisplay(x)
 107   align(x) <- switch(1+is.null(align), align, c("l",rep("r", ncol(x))))
 108   digits(x) <- switch(1+is.null(digits), digits, suggested.digits)
 109   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 110   return(x)
 111 }
 112
 113
 114 ### aov objects
 115 xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 116                        digits = NULL, display = NULL, auto = FALSE, ...) {
 117   return(xtable.anova(anova(x, ...), caption = caption, label = label,
 118                       align = align, digits = digits, display = display,
 119                       auto = auto, ...))
 120 }
 121
 122 xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 123                                digits = NULL, display = NULL, auto = FALSE,
 124                                ...) {
 125   return(xtable.anova(x[[1]], caption = caption, label = label, align = align,
 126                       digits = digits, display = display, auto = auto, ...))
 127 }
 128
 129 xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
 130                                    align = NULL, digits = NULL, display = NULL,
 131                                    auto = FALSE, ...) {
 132     for (i in 1:length(x)) {
 133         if (i == 1) {
 134             result <- xtable.summary.aov(x[[i]], caption = caption,
 135                                          label = label,
 136                                          align = align, digits = digits,
 137                                          display = display, auto = auto, ...)
 138         } else {
 139             result <- rbind(result,
 140                             xtable.anova(x[[i]][[1]], caption = caption,
 141                                          label = label, align = align,
 142                                          digits = digits, display = display,
 143                                          auto = auto, ...))
 144         }
 145     }
 146     return(result)
 147 }
 148
 149 xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
 150                            digits = NULL, display = NULL, auto = FALSE, ...) {
 151   return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
 152                                 align = align, digits = digits,
 153                                 display = display, auto = auto, ...))
 154 }
 155
 156
 157
 158 ### lm objects
 159 xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 160                       digits = NULL, display = NULL, auto = FALSE, ...) {
 161   return(xtable.summary.lm(summary(x), caption = caption, label = label,
 162                            align = align, digits = digits, display = display,
 163                            auto = auto, ...))
 164 }
 165
 166 xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 167                               digits = NULL, display = NULL, auto = FALSE,
 168                               ...) {
 169   x <- data.frame(x$coef, check.names = FALSE)
 170
 171   class(x) <- c("xtable","data.frame")
 172   caption(x) <- caption
 173   label(x) <- label
 174   if(auto && is.null(align))   align   <- xalign(x)
 175   if(auto && is.null(digits))  digits  <- xdigits(x)
 176   if(auto && is.null(display)) display <- xdisplay(x)
 177   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 178   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 179   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 180   return(x)
 181 }
 182
 183
 184 ### glm objects
 185 xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 186                        digits = NULL, display = NULL, auto = FALSE, ...) {
 187   return(xtable.summary.glm(summary(x), caption = caption,
 188                             label = label, align = align,
 189                             digits = digits, display = display,
 190                             auto = auto, ...))
 191 }
 192
 193 xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 194                                digits = NULL, display = NULL, auto = FALSE,
 195                                ...) {
 196   return(xtable.summary.lm(x, caption = caption, label = label, align = align,
 197                            digits = digits, display = display,
 198                            auto = auto, ...))
 199 }
 200
 201
 202 ### prcomp objects
 203 xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 204                           digits = NULL, display = NULL, auto = FALSE, ...) {
 205   x <- data.frame(x$rotation, check.names = FALSE)
 206
 207   class(x) <- c("xtable","data.frame")
 208   caption(x) <- caption
 209   label(x) <- label
 210   if(auto && is.null(align))   align   <- xalign(x)
 211   if(auto && is.null(digits))  digits  <- xdigits(x)
 212   if(auto && is.null(display)) display <- xdisplay(x)
 213   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 214   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 215   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 216   return(x)
 217 }
 218
 219 xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 220                                   digits = NULL, display = NULL, auto = FALSE,
 221                                   ...) {
 222   x <- data.frame(x$importance, check.names = FALSE)
 223
 224   class(x) <- c("xtable","data.frame")
 225   caption(x) <- caption
 226   label(x) <- label
 227   if(auto && is.null(align))   align   <- xalign(x)
 228   if(auto && is.null(digits))  digits  <- xdigits(x)
 229   if(auto && is.null(display)) display <- xdisplay(x)
 230   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 231   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 232   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 233   return(x)
 234 }
 235
 236
 237 ### Slightly modified version of xtable.coxph contributed on r-help by
 238 ###   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 239 ###   From: Jun Yan <jyan@stat.wisc.edu>
 240 ###   Subject: Re: [R] xtable for Cox model output
 241 xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
 242                           digits = NULL, display = NULL, auto = FALSE, ...)
 243 {
 244   cox <- x
 245   beta <- cox$coef
 246   se <- sqrt(diag(cox$var))
 247   if (is.null(cox$naive.var)) {
 248     tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
 249     dimnames(tmp) <- list(names(beta),
 250       c("coef", "exp(coef)", "se(coef)", "z", "p"))
 251   } else {
 252     tmp <- cbind( beta, exp(beta), se, beta/se,
 253       signif(1 - pchisq((beta/se)^2, 1), digits - 1))
 254     dimnames(tmp) <- list(names(beta),
 255       c("coef", "exp(coef)", "robust se", "z", "p"))
 256   }
 257   return(xtable(tmp, caption = caption, label = label, align = align,
 258                 digits = digits, display = display, auto = auto, ...))
 259 }
 260
 261 ### Additional method: xtable.ts
 262 ### Contributed by David Mitchell (davidm@netspeed.com.au)
 263 ### Date: July 2003
 264 xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
 265                       digits = NULL, display = NULL, auto = FALSE, ...) {
 266   if (inherits(x, "ts") && !is.null(ncol(x))) {
 267     ## COLNAMES <- paste(colnames(x));
 268     tp.1 <- trunc(time(x))
 269     tp.2 <- trunc(cycle(x))
 270     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 271     ROWNAMES <- switch(frequency(x),
 272                        tp.1,
 273                        "Arg2", "Arg3",              # Dummy arguments
 274                        paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
 275                        "Arg5", "Arg6",
 276                        paste("Wk.", tp.1, " ", day.abb[tp.2], sep = ""),
 277                        "Arg8", "Arg9", "Arg10", "Arg11",
 278                        paste(tp.1, month.abb[tp.2], sep = " "))
 279     tmp <- data.frame(x, row.names = ROWNAMES);
 280   } else if (inherits(x, "ts") && is.null(ncol(x))) {
 281     COLNAMES <- switch(frequency(x),
 282                        "Value",
 283                        "Arg2", "Arg3",              # Dummy arguments
 284                        c("Q1", "Q2", "Q3", "Q4"),
 285                        "Arg5", "Arg6",
 286                        day.abb,
 287                        "Arg8", "Arg9", "Arg10", "Arg11",
 288                        month.abb)
 289     ROWNAMES <- seq(from = start(x)[1], to = end(x)[1])
 290     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
 291                                rep(NA, frequency(x) - end(x)[2])),
 292                              ncol = frequency(x), byrow = TRUE),
 293                       row.names = ROWNAMES)
 294     names(tmp) <- COLNAMES
 295   }
 296   return(xtable(tmp, caption = caption, label = label, align = align,
 297                 digits = digits, display = display, auto = auto, ...))
 298 }
 299
 300 ### Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
 301 xtable.zoo <- function(x, caption = NULL, label = NULL, align = NULL,
 302                        digits = NULL, display = NULL, auto = FALSE, ...) {
 303   return(xtable(as.ts(x), caption = caption, label = label,
 304                 align = align, digits = digits,
 305                 display = display, auto = auto, ...))
 306 }
 307
 308 ### Date: Fri, 29 May 2015 11:41:04 +0200
 309 ### From: Martin G. <martin.gubri@framasoft.org>
 310 ### Subject: [xtable] Code for spdep, splm and sphet objects outputs
 311 ### package spdep
 312 ### sarlm objects
 313 xtable.sarlm <- function(x, caption = NULL, label = NULL, align = NULL,
 314                          digits = NULL, display = NULL, auto = FALSE, ...) {
 315   return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 316                               align = align, digits = digits,
 317                               display = display, auto = auto, ...))
 318 }
 319
 320 xtable.summary.sarlm <- function(x, caption = NULL, label = NULL, align = NULL,
 321                                 digits = NULL, display = NULL, auto = FALSE,
 322                                 ...) {
 323   x <- data.frame(x$Coef, check.names = FALSE)
 324
 325   class(x) <- c("xtable","data.frame")
 326   caption(x) <- caption
 327   label(x) <- label
 328   if(auto && is.null(align))   align   <- xalign(x)
 329   if(auto && is.null(digits))  digits  <- xdigits(x)
 330   if(auto && is.null(display)) display <- xdisplay(x)
 331   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 332   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 333   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 334   return(x)
 335 }
 336
 337 ### spautolm objects: added by David Scott, 6/1/2016, after suggestion by
 338 ### Guido Schulz
 339 ### Date: Wed, 29 Apr 2015 10:45:16 +0200
 340 ### Guido Schulz <schulzgu@student.hu-berlin.de>
 341 xtable.spautolm <- function(x, caption = NULL, label = NULL, align = NULL,
 342                             digits = NULL, display = NULL, auto = FALSE, ...) {
 343     return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 344                               align = align, digits = digits,
 345                               display = display, auto = auto, ...))
 346 }
 347
 348 xtable.summary.spautolm <- function(x, caption = NULL, label = NULL,
 349                                     align = NULL, digits = NULL,
 350                                     display = NULL, auto = FALSE, ...) {
 351     return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 352                               align = align, digits = digits,
 353                               display = display, auto = auto, ...))
 354 }
 355
 356
 357 ### gmsar objects
 358 xtable.gmsar <- function(x, caption = NULL, label = NULL, align = NULL,
 359                          digits = NULL, display = NULL, auto = FALSE, ...) {
 360     return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 361                               align = align, digits = digits,
 362                               display = display, auto = auto, ...))
 363 }
 364
 365 xtable.summary.gmsar <- function(x, caption = NULL, label = NULL, align = NULL,
 366                                  digits = NULL, display = NULL,
 367                                  auto = FALSE, ...) {
 368   return(xtable.summary.sarlm(x, caption = caption, label = label,
 369                               align = align, digits = digits,
 370                               display = display, auto = auto, ...))
 371 }
 372
 373 ### stsls objects
 374 xtable.stsls <- function(x, caption = NULL, label = NULL, align = NULL,
 375                          digits = NULL, display = NULL, auto = FALSE, ...) {
 376   return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
 377                               align = align, digits = digits,
 378                               display = display, auto = auto, ...))
 379 }
 380
 381 xtable.summary.stsls <- function(x, caption = NULL, label = NULL, align = NULL,
 382                                  digits = NULL, display = NULL,
 383                                  auto = FALSE, ...) {
 384   return(xtable.summary.sarlm(x, caption = caption, label = label,
 385                               align = align, digits = digits,
 386                               display = display, auto = auto, ...))
 387 }
 388
 389 ### pred.sarlm objects
 390 xtable.sarlm.pred <- function(x, caption = NULL, label = NULL, align = NULL,
 391                               digits = NULL, display = NULL,
 392                               auto = FALSE, ...) {
 393   return(xtable(as.data.frame(x), caption = caption, label = label,
 394                 align = align, digits = digits,
 395                 display = display, auto = auto, ...))
 396 }
 397
 398 ### lagImpact objects
 399 xtable.lagImpact <- function(x, caption = NULL, label = NULL, align = NULL,
 400                              digits = NULL, display = NULL,
 401                              auto = FALSE, ...) {
 402   requireNamespace('spdep')
 403   lagImpactMat <- get('lagImpactMat', environment(spdep::spdep))
 404   xtable(lagImpactMat(x), caption = caption, label = label,
 405          align = align, digits = digits,
 406          display = display, auto = auto, ...)
 407 }
 408
 409 ### package splm
 410 ### splm objects
 411 xtable.splm <- function(x, caption = NULL, label = NULL, align = NULL,
 412                         digits = NULL, display = NULL, auto = FALSE, ...) {
 413   return(xtable.summary.splm(summary(x), caption = caption, label = label,
 414                              align = align, digits = digits,
 415                              display = display, auto = auto, ...))
 416 }
 417
 418 xtable.summary.splm <- function(x, caption = NULL, label = NULL, align = NULL,
 419                                 digits = NULL, display = NULL, auto = FALSE,
 420                                 ...) {
 421   x <- data.frame(x$CoefTable, check.names = FALSE)
 422
 423   class(x) <- c("xtable","data.frame")
 424   caption(x) <- caption
 425   label(x) <- label
 426   if(auto && is.null(align))   align   <- xalign(x)
 427   if(auto && is.null(digits))  digits  <- xdigits(x)
 428   if(auto && is.null(display)) display <- xdisplay(x)
 429   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 430   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 431   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 432   return(x)
 433 }
 434
 435 ### package sphet
 436 ### sphet objects
 437 xtable.sphet <- function(x, caption = NULL, label = NULL, align = NULL,
 438                          digits = NULL, display = NULL, auto = FALSE, ...) {
 439   return(xtable.summary.splm(summary(x), caption = caption, label = label,
 440                              align = align, digits = digits,
 441                              display = display, auto = auto, ...))
 442 }
 443
 444 xtable.summary.sphet <- function(x, caption = NULL, label = NULL, align = NULL,
 445                                  digits = NULL, display = NULL,
 446                                  auto = FALSE, ...) {
 447   return(xtable.summary.splm(x, caption = caption, label = label,
 448                              align = align, digits = digits,
 449                              display = display, auto = auto, ...))
 450 }