3 ### Produce LaTeX and HTML tables from R objects.
5 ### Copyright 2000-2013 David B. Dahl <dahl@stat.tamu.edu>
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.
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
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
23 xtable <- function(x, caption = NULL, label = NULL, align = NULL,
24 digits = NULL, display = NULL, ...) {
29 ## data.frame and matrix objects
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")
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))
51 display[characters | factors] <- "s"
52 display <- c("s", display)
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))
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),
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))
82 stop("xtable.table is not implemented for tables of > 2 dimensions")
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
96 class(x) <- c("xtable","data.frame")
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))))
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))
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))
120 xtable.summary.aovlist <- function(x, caption = NULL, label = NULL,
122 digits = NULL, display = NULL, ...) {
123 for (i in 1:length(x)) {
125 result <- xtable.summary.aov(x[[i]], caption = caption,
127 align = align, digits = digits,
130 result <- rbind(result,
131 xtable.anova(x[[i]][[1]], caption = caption,
132 label = label, align = align,
133 digits = digits, display = display))
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,
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))
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)
160 class(x) <- c("xtable","data.frame")
161 caption(x) <- caption
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"))
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))
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))
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)
192 class(x) <- c("xtable","data.frame")
193 caption(x) <- caption
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))))
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)
205 class(x) <- c("xtable","data.frame")
206 caption(x) <- caption
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))))
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, ...)
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"))
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"))
236 return(xtable(tmp, caption = caption, label = label, align = align,
237 digits = digits, display = display))
240 # Additional method: xtable.ts
241 # Contributed by David Mitchell (davidm@netspeed.com.au)
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),
252 "Arg2", "Arg3", # Dummy arguments
253 paste(tp.1, c("Q1", "Q2", "Q3", "Q4")[tp.2], sep = " "),
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);
260 else if (inherits(x, "ts") && is.null(ncol(x))) {
261 COLNAMES <- switch(frequency(x),
263 "Arg2", "Arg3", # Dummy arguments
264 c("Q1", "Q2", "Q3", "Q4"),
267 "Arg8", "Arg9", "Arg10", "Arg11",
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
276 return(xtable(tmp, caption = caption, label = label, align = align,
277 digits = digits, display = display))
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), ...))