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 ### xtableMatharray object
  71 ### To deal with numeric arrays such as a variance-covariance matrix
  72 ### From a request by James Curran, 16 October 2015
  73 xtable.xtableMatharray <- function(x, caption = NULL, label = NULL,
  74                                    align = NULL, digits = NULL,
  75                                    display = NULL, auto = FALSE,
  76                                    ...) {
  77   class(x) <- c("xtableMatharray","matrix")
  78   xtbl <- xtable.matrix(x,
  79                         caption = caption, label = label, align = align,
  80                         digits = digits, display = display, auto = auto,
  81                         ...)
  82   class(xtbl) <- c("xtableMatharray","xtable","data.frame")
  83   return(xtbl)
  84 }
  85
  86 ### table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
  87 ### Fixed to pass R checks by DBD, 9 May 2007
  88 xtable.table <- function(x, caption = NULL, label = NULL, align = NULL,
  89                        digits = NULL, display = NULL, auto = FALSE, ...) {
  90   if (length(dim(x)) == 1) {
  91     return(xtable.matrix(matrix(x,
  92                                 dimnames = list(rownames(x),
  93                                                 names(dimnames(x)))),
  94                          caption = caption, label = label, align = align,
  95                          digits = digits, display = display, auto = auto))
  96   } else if (length(dim(x))==2) {
  97     return(xtable.matrix(matrix(x, ncol = dim(x)[2], nrow = dim(x)[1],
  98                                 dimnames = list(rownames(x), colnames(x))),
  99                          caption = caption, label = label, align = align,
 100                          digits = digits, display = display, auto = auto))
 101   } else {
 102     stop("xtable.table is not implemented for tables of > 2 dimensions")
 103   }
 104 }
 105
 106
 107 ### anova objects
 108
 109 xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
 110                          digits = NULL, display = NULL, auto = FALSE, ...) {
 111   suggested.digits <- c(0,rep(2, ncol(x)))
 112   suggested.digits[grep("Pr\\(>", names(x))+1] <- 4
 113   suggested.digits[grep("P\\(>", names(x))+1] <- 4
 114   suggested.digits[grep("Df", names(x))+1] <- 0
 115
 116   class(x) <- c("xtable","data.frame")
 117   caption(x) <- caption
 118   label(x) <- label
 119   if(auto && is.null(align))   align   <- xalign(x)
 120   if(auto && is.null(digits))  digits  <- xdigits(x)
 121   if(auto && is.null(display)) display <- xdisplay(x)
 122   align(x) <- switch(1+is.null(align), align, c("l",rep("r", ncol(x))))
 123   digits(x) <- switch(1+is.null(digits), digits, suggested.digits)
 124   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 125   return(x)
 126 }
 127
 128
 129 ### aov objects
 130
 131 xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 132                        digits = NULL, display = NULL, auto = FALSE, ...) {
 133   return(xtable.anova(anova(x, ...), caption = caption, label = label,
 134                       align = align, digits = digits, display = display,
 135                       auto = auto))
 136 }
 137
 138 xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
 139                                digits = NULL, display = NULL, auto = FALSE,
 140                                ...) {
 141   return(xtable.anova(x[[1]], caption = caption, label = label, align = align,
 142                       digits = digits, display = display, auto = auto))
 143 }
 144
 145 xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
 146                                    align = NULL, digits = NULL, display = NULL,
 147                                    auto = FALSE, ...) {
 148     for (i in 1:length(x)) {
 149         if (i == 1) {
 150             result <- xtable.summary.aov(x[[i]], caption = caption,
 151                                          label = label,
 152                                          align = align, digits = digits,
 153                                          display = display, auto = auto)
 154         } else {
 155             result <- rbind(result,
 156                             xtable.anova(x[[i]][[1]], caption = caption,
 157                                          label = label, align = align,
 158                                          digits = digits, display = display,
 159                                          auto = auto))
 160         }
 161     }
 162     return(result)
 163 }
 164
 165 xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
 166                            digits = NULL, display = NULL, auto = FALSE, ...) {
 167   return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
 168                                 align = align, digits = digits,
 169                                 display = display, auto = auto))
 170 }
 171
 172
 173
 174 ### lm objects
 175
 176 xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 177                       digits = NULL, display = NULL, auto = FALSE, ...) {
 178   return(xtable.summary.lm(summary(x), caption = caption, label = label,
 179                            align = align, digits = digits, display = display,
 180                            auto = auto))
 181 }
 182
 183 xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 184                               digits = NULL, display = NULL, auto = FALSE,
 185                               ...) {
 186   x <- data.frame(x$coef, check.names = FALSE)
 187
 188   class(x) <- c("xtable","data.frame")
 189   caption(x) <- caption
 190   label(x) <- label
 191   if(auto && is.null(align))   align   <- xalign(x)
 192   if(auto && is.null(digits))  digits  <- xdigits(x)
 193   if(auto && is.null(display)) display <- xdisplay(x)
 194   align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
 195   digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
 196   display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
 197   return(x)
 198 }
 199
 200
 201 ### glm objects
 202
 203 xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 204                        digits = NULL, display = NULL, auto = FALSE, ...) {
 205   return(xtable.summary.glm(summary(x), caption = caption,
 206                             label = label, align = align,
 207                             digits = digits, display = display, auto = auto))
 208 }
 209
 210 xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
 211                                digits = NULL, display = NULL, auto = FALSE,
 212                                ...) {
 213   return(xtable.summary.lm(x, caption = caption, label = label, align = align,
 214                            digits = digits, display = display, auto = auto))
 215 }
 216
 217
 218 ### prcomp objects
 219
 220 xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 221                           digits = NULL, display = NULL, auto = FALSE, ...) {
 222   x <- data.frame(x$rotation, 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 xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 237                                   digits = NULL, display = NULL, auto = FALSE,
 238                                   ...) {
 239   x <- data.frame(x$importance, check.names = FALSE)
 240
 241   class(x) <- c("xtable","data.frame")
 242   caption(x) <- caption
 243   label(x) <- label
 244   if(auto && is.null(align))   align   <- xalign(x)
 245   if(auto && is.null(digits))  digits  <- xdigits(x)
 246   if(auto && is.null(display)) display <- xdisplay(x)
 247   align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
 248   digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
 249   display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
 250   return(x)
 251 }
 252
 253
 254 # Slightly modified version of xtable.coxph contributed on r-help by
 255 #   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
 256 #   From: Jun Yan <jyan@stat.wisc.edu>
 257 #   Subject: Re: [R] xtable for Cox model output
 258 xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
 259                           digits = NULL, display = NULL, auto = FALSE, ...)
 260 {
 261   cox <- x
 262   beta <- cox$coef
 263   se <- sqrt(diag(cox$var))
 264   if (is.null(cox$naive.var)) {
 265     tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
 266     dimnames(tmp) <- list(names(beta),
 267       c("coef", "exp(coef)", "se(coef)", "z", "p"))
 268   } else {
 269     tmp <- cbind( beta, exp(beta), se, beta/se,
 270       signif(1 - pchisq((beta/se)^2, 1), digits - 1))
 271     dimnames(tmp) <- list(names(beta),
 272       c("coef", "exp(coef)", "robust se", "z", "p"))
 273   }
 274   return(xtable(tmp, caption = caption, label = label, align = align,
 275                 digits = digits, display = display, auto = auto))
 276 }
 277
 278 # Additional method: xtable.ts
 279 # Contributed by David Mitchell (davidm@netspeed.com.au)
 280 # Date: July 2003
 281 xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
 282                       digits = NULL, display = NULL, auto = FALSE, ...) {
 283   if (inherits(x, "ts") && !is.null(ncol(x))) {
 284     # COLNAMES <- paste(colnames(x));
 285     tp.1 <- trunc(time(x))
 286     tp.2 <- trunc(cycle(x))
 287     day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
 288     ROWNAMES <- switch(frequency(x),
 289                        tp.1,
 290                        "Arg2", "Arg3",              # Dummy arguments
 291                        paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
 292                        "Arg5", "Arg6",
 293                        paste("Wk.", tp.1, " ", day.abb[tp.2], sep = ""),
 294                        "Arg8", "Arg9", "Arg10", "Arg11",
 295                        paste(tp.1, month.abb[tp.2], sep = " "))
 296     tmp <- data.frame(x, row.names = ROWNAMES);
 297   } else if (inherits(x, "ts") && is.null(ncol(x))) {
 298     COLNAMES <- switch(frequency(x),
 299                        "Value",
 300                        "Arg2", "Arg3",              # Dummy arguments
 301                        c("Q1", "Q2", "Q3", "Q4"),
 302                        "Arg5", "Arg6",
 303                        day.abb,
 304                        "Arg8", "Arg9", "Arg10", "Arg11",
 305                        month.abb)
 306     ROWNAMES <- seq(from = start(x)[1], to = end(x)[1])
 307     tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
 308                                rep(NA, frequency(x) - end(x)[2])),
 309                              ncol = frequency(x), byrow = TRUE),
 310                       row.names = ROWNAMES)
 311     names(tmp) <- COLNAMES
 312   }
 313   return(xtable(tmp, caption = caption, label = label, align = align,
 314                 digits = digits, display = display, auto = auto))
 315 }
 316
 317 ### Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
 318 xtable.zoo <- function(x, ...) {
 319   return(xtable(as.ts(x), ...))
 320 }
 321
 322 ### Function to create lists of tables
 323 xtable.xtableList <- function(x, caption = NULL, label = NULL, align = NULL,
 324                               digits = NULL, display = NULL, ...) {
 325   if (is.null(digits)){
 326     digitsList <- vector("list", length(x))
 327   } else {
 328     if (!is.list(digits)){
 329       digitsList <- vector("list", length(x))
 330       for (i in 1:length(x)) digitsList[[i]] <- digits
 331     }
 332   }
 333   if (is.null(display)){
 334     displayList <- vector("list", length(x))
 335   } else {
 336     if (!is.list(display)){
 337       displayList <- vector("list", length(x))
 338       for (i in 1:length(x)) displayList[[i]] <- display
 339     }
 340   }
 341   xList <- vector("list", length(x))
 342   for (i in 1:length(x)){
 343     xList[[i]] <- xtable(x[[i]], caption = caption, label = label,
 344                          align = align, digits = digitsList[[i]],
 345                          display = displayList[[i]], ...)
 346     attr(xList[[i]], 'subheading') <- attr(x, 'subheadings')[[i]]
 347   }
 348   attr(xList, "message") <- attr(x, "message")
 349   attr(xList, "caption") <- caption
 350   attr(xList, "label") <- label
 351   return(xList)
 352 }
 353
 354 ### Uses xtable.xtableList
 355 xtable.lsmeans <- function(x, caption = NULL, label = NULL,
 356                            align = NULL, digits = NULL,
 357                            display = NULL, auto = FALSE,
 358                            ...){
 359   if (attr(x, "estName") == "lsmean"){
 360     xList <- split(x, f = x[, 2])
 361     for (i in 1:length(xList)){
 362       xList[[i]] <- as.data.frame(xList[[i]][, -2])
 363     }
 364     attr(xList, "subheadings") <-
 365       paste0(dimnames(x)[[2]][2], " = ", levels(x[[2]]))
 366     attr(xList, "message") <- c("", attr(x, "mesg"))
 367     xList <- xtable.xtableList(xList, caption =caption, label = label,
 368                            align = align, digits = digits,
 369                            display = display, auto = auto, ...)
 370   } else {
 371     xList <- x
 372     xList <- xtable.data.frame(xList, caption =caption, label = label,
 373                            align = align, digits = digits,
 374                            display = display, auto = auto, ...)
 375   }
 376   return(xList)
 377 }