]> git.donarmstrong.com Git - xtable.git/blobdiff - pkg/R/xtable.R
projects / xtable.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Completed addition of function print.xtableMatharray.R including test code in tests...
[xtable.git] / pkg / R / xtable.R
diff --git a/pkg/R/xtable.R b/pkg/R/xtable.R
index 47af4d4d6077d0815ad8676ec4d4488ff9a9f6b6..e3c1e048b17788e61d70239c2739c8bd6d7becc7 100644 (file)
--- a/pkg/R/xtable.R
+++ b/pkg/R/xtable.R
@@ -2,7 +2,7 @@
 ###
 ### Produce LaTeX and HTML tables from R objects.
 ###
-### Copyright 2000-2013 David B. Dahl <dahl@stat.tamu.edu>
+### 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
@@ -21,15 +21,16 @@
 ### MA 02111-1307, USA
 
 xtable <- function(x, caption = NULL, label = NULL, align = NULL,
-                   digits = NULL, display = NULL, ...) {
+                   digits = NULL, display = NULL, auto = FALSE, ...) {
   UseMethod("xtable")
 }
 
 
-## data.frame and matrix objects
+### data.frame and matrix objects
 
 xtable.data.frame <- function(x, caption = NULL, label = NULL, align = NULL,
-                              digits = NULL, display = 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
@@ -41,6 +42,9 @@ xtable.data.frame <- function(x, caption = NULL, label = NULL, align = NULL,
   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))))
@@ -56,38 +60,54 @@ xtable.data.frame <- function(x, caption = NULL, label = NULL, align = NULL,
 }
 
 xtable.matrix <- function(x, caption = NULL, label = NULL, align = NULL,
-                          digits = NULL, display = 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))
+                           digits = digits, display = display, auto = auto,
+                           ...))
 }
 
+### xtableMatharray object
+### To deal with numeric arrays such as a variance-covariance matrix
+### From a request by James Curran, 16 October 2015
+xtable.xtableMatharray <- function(x, caption = NULL, label = NULL,
+                                   align = NULL, digits = NULL,
+                                   display = NULL, auto = FALSE,
+                                   ...) {
+  class(x) <- c("xtableMatharray","matrix")
+  xtbl <- xtable.matrix(x,
+                        caption = caption, label = label, align = align,
+                        digits = digits, display = display, auto = auto,
+                        ...)
+  class(xtbl) <- c("xtableMatharray","xtable","data.frame")
+  return(xtbl)
+}
 
 ### 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, ...) {
+                       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))
+                         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))
+                         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
+### anova objects
 
 xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
-                         digits = NULL, display = 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
@@ -96,6 +116,9 @@ xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
   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))))
@@ -103,63 +126,71 @@ xtable.anova <- function(x, caption = NULL, label = NULL, align = NULL,
 }
 
 
-## aov objects
+### aov objects
 
 xtable.aov <- function(x, caption = NULL, label = NULL, align = NULL,
-                       digits = NULL, display = NULL, ...) {
+                       digits = NULL, display = NULL, auto = FALSE, ...) {
   return(xtable.anova(anova(x, ...), caption = caption, label = label,
-                      align = align, digits = digits, display = display))
+                      align = align, digits = digits, display = display,
+                      auto = auto))
 }
 
 xtable.summary.aov <- function(x, caption = NULL, label = NULL, align = NULL,
-                               digits = NULL, display = NULL, ...) {
-  return(xtable.anova(x[[1]], caption = caption, label = label,
-                      align = align, digits = digits, display = display))
+                               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, ...) {
+                                   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)
+                                         display = display, auto = auto)
         } else {
             result <- rbind(result,
                             xtable.anova(x[[i]][[1]], caption = caption,
                                          label = label, align = align,
-                                         digits = digits, display = display))
+                                         digits = digits, display = display,
+                                         auto = auto))
         }
     }
     return(result)
 }
 
 xtable.aovlist <- function(x, caption = NULL, label = NULL, align = NULL,
-                           digits = NULL, display = NULL, ...) {
+                           digits = NULL, display = NULL, auto = FALSE, ...) {
   return(xtable.summary.aovlist(summary(x), caption = caption, label = label,
                                 align = align, digits = digits,
-                                display = display))
+                                display = display, auto = auto))
 }
 
 
 
-## lm objects
+### lm objects
 
 xtable.lm <- function(x, caption = NULL, label = NULL, align = NULL,
-                      digits = NULL, display = NULL, ...) {
+                      digits = NULL, display = NULL, auto = FALSE, ...) {
   return(xtable.summary.lm(summary(x), caption = caption, label = label,
-                           align = align, digits = digits, display = display))
+                           align = align, digits = digits, display = display,
+                           auto = auto))
 }
 
 xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
-                              digits = NULL, display = 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"))
@@ -167,31 +198,35 @@ xtable.summary.lm <- function(x, caption = NULL, label = NULL, align = NULL,
 }
 
 
-## glm objects
+### glm objects
 
 xtable.glm <- function(x, caption = NULL, label = NULL, align = NULL,
-                       digits = NULL, display = NULL, ...) {
+                       digits = NULL, display = NULL, auto = FALSE, ...) {
   return(xtable.summary.glm(summary(x), caption = caption,
                             label = label, align = align,
-                            digits = digits, display = display))
+                            digits = digits, display = display, auto = auto))
 }
 
 xtable.summary.glm <- function(x, caption = NULL, label = NULL, align = NULL,
-                               digits = NULL, display = NULL, ...) {
-  return(xtable.summary.lm(x, caption = caption, label = label,
-                           align = align, digits = digits, display = display))
+                               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
+### prcomp objects
 
 xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
-                          digits = NULL, display = 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))))
@@ -199,12 +234,16 @@ xtable.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 }
 
 xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
-                                  digits = NULL, display = 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))))
@@ -217,7 +256,7 @@ xtable.summary.prcomp <- function(x, caption = NULL, label = NULL, align = NULL,
 #   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, ...)
+                          digits = NULL, display = NULL, auto = FALSE, ...)
 {
   cox <- x
   beta <- cox$coef
@@ -226,22 +265,21 @@ xtable.coxph <- function (x, caption = NULL, label = NULL, align = NULL,
     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 {
+  } 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))
+                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, ...) {
+                      digits = NULL, display = NULL, auto = FALSE, ...) {
   if (inherits(x, "ts") && !is.null(ncol(x))) {
     # COLNAMES <- paste(colnames(x));
     tp.1 <- trunc(time(x))
@@ -256,8 +294,7 @@ xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
                        "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))) {
+  } else if (inherits(x, "ts") && is.null(ncol(x))) {
     COLNAMES <- switch(frequency(x),
                        "Value",
                        "Arg2", "Arg3",              # Dummy arguments
@@ -274,7 +311,7 @@ xtable.ts <- function(x, caption = NULL, label = NULL, align = NULL,
     names(tmp) <- COLNAMES
   }
   return(xtable(tmp, caption = caption, label = label, align = align,
-                digits = digits, display = display))
+                digits = digits, display = display, auto = auto))
 }
 
 # Suggested by Ajay Narottam Shah <ajayshah@mayin.org> in e-mail 2006/07/22
Unnamed repository; edit this file 'description' to name the repository.