R/xtable.R

Defines functions xtable.summary.sphet xtable.sphet xtable.summary.splm xtable.splm xtable.lagImpact xtable.sarlm.pred xtable.summary.stsls xtable.stsls xtable.summary.gmsar xtable.gmsar xtable.summary.spautolm xtable.spautolm xtable.summary.sarlm xtable.sarlm xtable.zoo xtable.ts xtable.summary.prcomp xtable.prcomp xtable.summary.glm xtable.glm xtable.summary.lm xtable.lm xtable.aovlist xtable.summary.aovlist xtable.summary.aov xtable.aov xtable.anova xtable.table xtable.matrix xtable.data.frame xtable

Documented in xtable xtable.anova xtable.aov xtable.aovlist xtable.data.frame xtable.glm xtable.gmsar xtable.lagImpact xtable.lm xtable.matrix xtable.prcomp xtable.sarlm xtable.sarlm.pred xtable.spautolm xtable.sphet xtable.splm xtable.stsls xtable.summary.aov xtable.summary.aovlist xtable.summary.glm xtable.summary.gmsar xtable.summary.lm xtable.summary.prcomp xtable.summary.sarlm xtable.summary.spautolm xtable.summary.sphet xtable.summary.splm xtable.summary.stsls xtable.table xtable.ts xtable.zoo

### xtable package
###
### Produce LaTeX and HTML tables from R objects.
###
### Copyright 2000-2013 David B. Dahl <dahl@stat.byu.edu>
###
### This file is part of the `xtable' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
###
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
###
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA

xtable <- function(x, caption = NULL, label = NULL, align = NULL,
                   digits = NULL, display = NULL, auto = FALSE, ...) {
  UseMethod("xtable")
}


### data.frame and matrix objects

xtable.data.frame <- function(x, caption = NULL, label = NULL, align = NULL,
                              digits = NULL, display = NULL, auto = FALSE,
                              ...) {
  logicals <- unlist(lapply(x, is.logical))
  ##x[, logicals] <- lapply(x[, logicals], as.character)
  ## Patch for logicals bug, no 1911
  ## David Scott, <d.scott@auckland.ac.nz>, 2012-08-10
  x[, logicals] <- lapply(x[, logicals, drop = FALSE], as.character)
  characters <- unlist(lapply(x, is.character))
  factors <- unlist(lapply(x, is.factor))
  ints <- sapply(x, is.integer)
  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align,
                     c("r",c("r","l")[(characters|factors)+1]))
  digits(x) <- switch(1+is.null(digits), digits, c(0,rep(2,ncol(x))))
  ## Patch from Seth Falcon <sfalcon@fhcrc.org>, 18-May-2007
  if (is.null(display)) {
      display <- rep("f", ncol(x))
      display[ints] <- "d"
      display[characters | factors] <- "s"
      display <- c("s", display)
  }
  display(x) <- display
  return(x)
}

xtable.matrix <- function(x, caption = NULL, label = NULL, align = NULL,
                          digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.data.frame(data.frame(x, check.names = FALSE),
                           caption = caption, label = label, align = align,
                           digits = digits, display = display, auto = auto,
                           ...))
}



### table objects (of 1 or 2 dimensions) by Guido Gay, 9 Feb 2007
### Fixed to pass R checks by DBD, 9 May 2007
xtable.table <- function(x, caption = NULL, label = NULL, align = NULL,
                       digits = NULL, display = NULL, auto = FALSE, ...) {
  if (length(dim(x)) == 1) {
    return(xtable.matrix(matrix(x,
                                dimnames = list(rownames(x),
                                                names(dimnames(x)))),
                         caption = caption, label = label, align = align,
                         digits = digits, display = display, auto = auto, ...))
  } else if (length(dim(x))==2) {
    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, auto = auto, ...))
  } else {
    stop("xtable.table is not implemented for tables of > 2 dimensions")
  }
}


### anova objects
xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
                         digits = NULL, display = NULL, auto = FALSE, ...) {
  suggested.digits <- c(0,rep(2, ncol(x)))
  suggested.digits[grep("Pr\\(>", names(x))+1] <- 4
  suggested.digits[grep("P\\(>", names(x))+1] <- 4
  suggested.digits[grep("Df", names(x))+1] <- 0

  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align, c("l",rep("r", ncol(x))))
  digits(x) <- switch(1+is.null(digits), digits, suggested.digits)
  display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
  return(x)
}


### aov objects
xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
                       digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.anova(anova(x, ...), caption = caption, label = label,
                      align = align, digits = digits, display = display,
                      auto = auto, ...))
}

xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
                               digits = NULL, display = NULL, auto = FALSE,
                               ...) {
  return(xtable.anova(x[[1]], caption = caption, label = label, align = align,
                      digits = digits, display = display, auto = auto, ...))
}

xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
                                   align = NULL, digits = NULL, display = NULL,
                                   auto = FALSE, ...) {
    for (i in 1:length(x)) {
        if (i == 1) {
            result <- xtable.summary.aov(x[[i]], caption = caption,
                                         label = label,
                                         align = align, digits = digits,
                                         display = display, auto = auto, ...)
        } else {
            result <- rbind(result,
                            xtable.anova(x[[i]][[1]], caption = caption,
                                         label = label, align = align,
                                         digits = digits, display = display,
                                         auto = auto, ...))
        }
    }
    return(result)
}

xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
                           digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
                                align = align, digits = digits,
                                display = display, auto = auto, ...))
}



### lm objects
xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
                      digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.lm(summary(x), caption = caption, label = label,
                           align = align, digits = digits, display = display,
                           auto = auto, ...))
}

xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
                              digits = NULL, display = NULL, auto = FALSE,
                              ...) {
  x <- data.frame(x$coef, check.names = FALSE)

  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
  digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
  display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
  return(x)
}


### glm objects
xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
                       digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.glm(summary(x), caption = caption,
                            label = label, align = align,
                            digits = digits, display = display,
                            auto = auto, ...))
}

xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
                               digits = NULL, display = NULL, auto = FALSE,
                               ...) {
  return(xtable.summary.lm(x, caption = caption, label = label, align = align,
                           digits = digits, display = display,
                           auto = auto, ...))
}


### prcomp objects
xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
                          digits = NULL, display = NULL, auto = FALSE, ...) {
  x <- data.frame(x$rotation, check.names = FALSE)

  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
  digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
  display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
  return(x)
}

xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
                                  digits = NULL, display = NULL, auto = FALSE,
                                  ...) {
  x <- data.frame(x$importance, check.names = FALSE)

  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align, c("r",rep("r", ncol(x))))
  digits(x) <- switch(1+is.null(digits), digits, c(0,rep(4, ncol(x))))
  display(x) <- switch(1+is.null(display), display, c("s",rep("f", ncol(x))))
  return(x)
}


### Slightly modified version of xtable.coxph contributed on r-help by
###   Date: Wed, 2 Oct 2002 17:47:56 -0500 (CDT)
###   From: Jun Yan <jyan@stat.wisc.edu>
###   Subject: Re: [R] xtable for Cox model output
xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
                          digits = NULL, display = NULL, auto = FALSE, ...)
{
  cox <- x
  beta <- cox$coef
  se <- sqrt(diag(cox$var))
  if (is.null(cox$naive.var)) {
    tmp <- cbind(beta, exp(beta), se, beta/se, 1 - pchisq((beta/se)^2, 1))
    dimnames(tmp) <- list(names(beta),
      c("coef", "exp(coef)", "se(coef)", "z", "p"))
  } else {
    tmp <- cbind( beta, exp(beta), se, beta/se,
      signif(1 - pchisq((beta/se)^2, 1), digits - 1))
    dimnames(tmp) <- list(names(beta),
      c("coef", "exp(coef)", "robust se", "z", "p"))
  }
  return(xtable(tmp, caption = caption, label = label, align = align,
                digits = digits, display = display, auto = auto, ...))
}

### Additional method: xtable.ts
### Contributed by David Mitchell (davidm@netspeed.com.au)
### Date: July 2003
xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
                      digits = NULL, display = NULL, auto = FALSE, ...) {
  if (inherits(x, "ts") && !is.null(ncol(x))) {
    ## COLNAMES <- paste(colnames(x));
    tp.1 <- trunc(time(x))
    tp.2 <- trunc(cycle(x))
    day.abb <- c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    ROWNAMES <- switch(frequency(x),
                       tp.1,
                       "Arg2", "Arg3",              # Dummy arguments
                       paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
                       "Arg5", "Arg6",
                       paste("Wk.", tp.1, " ", day.abb[tp.2], sep = ""),
                       "Arg8", "Arg9", "Arg10", "Arg11",
                       paste(tp.1, month.abb[tp.2], sep = " "))
    tmp <- data.frame(x, row.names = ROWNAMES);
  } else if (inherits(x, "ts") && is.null(ncol(x))) {
    COLNAMES <- switch(frequency(x),
                       "Value",
                       "Arg2", "Arg3",              # Dummy arguments
                       c("Q1", "Q2", "Q3", "Q4"),
                       "Arg5", "Arg6",
                       day.abb,
                       "Arg8", "Arg9", "Arg10", "Arg11",
                       month.abb)
    ROWNAMES <- seq(from = start(x)[1], to = end(x)[1])
    tmp <- data.frame(matrix(c(rep(NA, start(x)[2] - 1), x,
                               rep(NA, frequency(x) - end(x)[2])),
                             ncol = frequency(x), byrow = TRUE),
                      row.names = ROWNAMES)
    names(tmp) <- COLNAMES
  }
  return(xtable(tmp, caption = caption, label = label, align = align,
                digits = digits, display = display, auto = auto, ...))
}

### Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
xtable.zoo <- function(x, caption = NULL, label = NULL, align = NULL,
                       digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable(as.ts(x), caption = caption, label = label,
                align = align, digits = digits,
                display = display, auto = auto, ...))
}

### Date: Fri, 29 May 2015 11:41:04 +0200
### From: Martin G. <martin.gubri@framasoft.org>
### Subject: [xtable] Code for spdep, splm and sphet objects outputs
### package spdep
### sarlm objects
xtable.sarlm <- function(x, caption = NULL, label = NULL, align = NULL,
                         digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}

xtable.summary.sarlm <- function(x, caption = NULL, label = NULL, align = NULL,
                                digits = NULL, display = NULL, auto = FALSE,
                                ...) {
  x <- data.frame(x$Coef, check.names = FALSE)

  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
  digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
  display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
  return(x)
}

### spautolm objects: added by David Scott, 6/1/2016, after suggestion by
### Guido Schulz
### Date: Wed, 29 Apr 2015 10:45:16 +0200
### Guido Schulz <schulzgu@student.hu-berlin.de>
xtable.spautolm <- function(x, caption = NULL, label = NULL, align = NULL,
                            digits = NULL, display = NULL, auto = FALSE, ...) {
    return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}

xtable.summary.spautolm <- function(x, caption = NULL, label = NULL,
                                    align = NULL, digits = NULL,
                                    display = NULL, auto = FALSE, ...) {
    return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}


### gmsar objects
xtable.gmsar <- function(x, caption = NULL, label = NULL, align = NULL,
                         digits = NULL, display = NULL, auto = FALSE, ...) {
    return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}

xtable.summary.gmsar <- function(x, caption = NULL, label = NULL, align = NULL,
                                 digits = NULL, display = NULL,
                                 auto = FALSE, ...) {
  return(xtable.summary.sarlm(x, caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}

### stsls objects
xtable.stsls <- function(x, caption = NULL, label = NULL, align = NULL,
                         digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.sarlm(summary(x), caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}

xtable.summary.stsls <- function(x, caption = NULL, label = NULL, align = NULL,
                                 digits = NULL, display = NULL,
                                 auto = FALSE, ...) {
  return(xtable.summary.sarlm(x, caption = caption, label = label,
                              align = align, digits = digits,
                              display = display, auto = auto, ...))
}

### pred.sarlm objects
xtable.sarlm.pred <- function(x, caption = NULL, label = NULL, align = NULL,
                              digits = NULL, display = NULL,
                              auto = FALSE, ...) {
  return(xtable(as.data.frame(x), caption = caption, label = label,
                align = align, digits = digits,
                display = display, auto = auto, ...))
}

### lagImpact objects
xtable.lagImpact <- function(x, caption = NULL, label = NULL, align = NULL,
                             digits = NULL, display = NULL,
                             auto = FALSE, ...) {
  requireNamespace('spdep')
  lagImpactMat <- get('lagImpactMat', environment(spdep::spdep))
  xtable(lagImpactMat(x), caption = caption, label = label,
         align = align, digits = digits,
         display = display, auto = auto, ...)
}

## package splm
## splm objects
xtable.splm <- function(x, caption = NULL, label = NULL, align = NULL,
                        digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.splm(summary(x), caption = caption, label = label,
                             align = align, digits = digits,
                             display = display, auto = auto, ...))
}

xtable.summary.splm <- function(x, caption = NULL, label = NULL, align = NULL,
                                digits = NULL, display = NULL, auto = FALSE,
                                ...) {
  x <- data.frame(x$CoefTable, check.names = FALSE)

  class(x) <- c("xtable","data.frame")
  caption(x) <- caption
  label(x) <- label
  if(auto && is.null(align))   align   <- xalign(x)
  if(auto && is.null(digits))  digits  <- xdigits(x)
  if(auto && is.null(display)) display <- xdisplay(x)
  align(x) <- switch(1+is.null(align), align, c("r","r","r","r","r"))
  digits(x) <- switch(1+is.null(digits), digits, c(0,4,4,2,4))
  display(x) <- switch(1+is.null(display), display, c("s","f","f","f","f"))
  return(x)
}

## package sphet
## sphet objects
xtable.sphet <- function(x, caption = NULL, label = NULL, align = NULL,
                         digits = NULL, display = NULL, auto = FALSE, ...) {
  return(xtable.summary.splm(summary(x), caption = caption, label = label,
                             align = align, digits = digits,
                             display = display, auto = auto, ...))
}

xtable.summary.sphet <- function(x, caption = NULL, label = NULL, align = NULL,
                                 digits = NULL, display = NULL,
                                 auto = FALSE, ...) {
  return(xtable.summary.splm(x, caption = caption, label = label,
                             align = align, digits = digits,
                             display = display, auto = auto, ...))
}

Try the xtable package in your browser

Any scripts or data that you put into this service are public.

xtable documentation built on June 15, 2020, 3 p.m.