Merge pull request #161 from RomanTsegelskyi/tabular

S3 method for tabular class fix #147

.travis.yml

@@ -18,7 +18,7 @@ install:
   - "[ ! -d ~/R ] && mkdir ~/R"
   - R --version
   - R -e '.libPaths(); sessionInfo()'
-  - Rscript -e 'install.packages(c("ggplot2", "testthat", "koRpus", "descr", "Rcpp", "microbenchmark", "pander", "devtools", "XML"), dep = TRUE, repos = "http://cran.r-project.org")'
+  - Rscript -e 'install.packages(c("ggplot2", "testthat", "koRpus", "descr", "Rcpp", "microbenchmark", "pander", "devtools", "XML", "tables"), dep = TRUE, repos = "http://cran.r-project.org")'
   - Rscript -e 'devtools::install_github("jimhester/covr")'
 
 # run tests

DESCRIPTION

@@ -36,7 +36,8 @@ Suggests:
     nlme,
     descr,
     MASS,
-    knitr
+    knitr, 
+    tables
 SystemRequirements: pandoc (http://johnmacfarlane.net/pandoc) for exporting
     markdown files to other formats.
 LinkingTo: Rcpp

NAMESPACE

@@ -47,6 +47,7 @@ S3method(pander,summary.prcomp)
 S3method(pander,survdiff)
 S3method(pander,survfit)
 S3method(pander,table)
+S3method(pander,tabular)
 S3method(pander,ts)
 S3method(pander,zoo)
 export(Pandoc)

R/S3.R

@@ -1506,3 +1506,55 @@ pander.function <- function(x, add.name = FALSE, verbatim = TRUE, syntax.highlig
         cat('```')
 
 }
+
+
+#' Pander method for tabular class
+#'
+#' Renders an tabular object in Pandoc's markdown.
+#' @param x an function object
+#' @param caption 
+#' @param digits number of digits of precision
+#' @param emphasize.rownames (defaut:\code{TRUE}) if rownames should be highlighted
+#' @param ... optional parameters passed to raw \code{pandoc.table} function
+#' @export
+#' @examples
+#' pander(tabular(as.factor(am) ~ (mpg+hp+qsec) * (mean+median), data = mtcars), split.tables = Inf)
+#' pander(tabular( (Species + 1) ~ (n=1) + Format(digits=2)*
+#' (Sepal.Length + Sepal.Width)*(mean + sd), data=iris ), split.tables = Inf)
+#' Sex <- factor(sample(c("Male", "Female"), 100, rep=TRUE))
+#' Status <- factor(sample(c("low", "medium", "high"), 100, rep=TRUE))
+#' z <- rnorm(100)+5
+#' fmt <- function(x) {
+#'    s <- format(x, digits=2)
+#'    even <- ((1:length(s)) %% 2) == 0
+#'    s[even] <- sprintf("(%s)", s[even])
+#'    s
+#' }
+#' tab <- tabular( Justify(c)*Heading()*z*Sex*Heading(Statistic)*Format(fmt())*(mean+sd) 
+#'                ~ Status )
+#' pander(tab, emphasize.rownames = FALSE)               
+pander.tabular <- function(x, caption = attr(x, 'caption'), emphasize.rownames = TRUE, digits = panderOptions('digits'), ...) {
+    if (is.null(caption) & !is.null(storage$caption))
+        caption <- get.caption()
+    data <- as.matrix(x, format = T, rowLabels = F, colLabels = F, digits = digits)
+    rlabels <- attr(x, "rowLabels")
+    rlabels[is.na(rlabels)] <- ""
+    clabels <- attr(x, "colLabels")
+    clabels[is.na(clabels)] <- ""
+    if (!is.null(colnames(rlabels))) { # needed for case of more complex tabular structure (see examples)
+        cl <- colnames(rlabels)
+        data <- cbind(rlabels, data)
+        clabels <- cbind(rbind(matrix("", 
+                                      nrow = (nrow(clabels) - 1), 
+                                      ncol = length(cl)),
+                               colnames(rlabels)), 
+                         clabels)
+    } 
+    clabels <- apply(clabels, c(2), paste, collapse = "\\ \n")
+    colnames(data) <- clabels
+    if (emphasize.rownames)
+        pandoc.table(data, caption = caption, keep.line.breaks = TRUE, emphasize.cols = 1:length(cl), ...)
+    else
+        pandoc.table(data, caption = caption, keep.line.breaks = TRUE, ...)
+}
+

inst/tests/test-S3.R

@@ -363,3 +363,13 @@ test_that('table.expand behaves correctly',{
   # unicode string issue
   expect_equal(pandoc.table.return(data.frame(a = 'ßß')), "\n---\n a \n---\nßß \n---\n\n")
 })
+
+context("S3 methods")
+
+test_that('pander.tabular behaves correctly', {
+    suppressMessages(require(tables))
+    tab <- pander.return(tables::tabular(as.factor(am) ~ (mpg+hp+qsec) * (mean+median), data = mtcars), emphasize.rownames = FALSE, split.tables = Inf)
+    expect_equal(length(tab), 10)
+    tab <- pander.return(tables::tabular( (Species + 1) ~ (n=1) + Format(digits=2)* (Sepal.Length + Sepal.Width)*(mean + sd), data=iris ), split.tables = Inf)
+    expect_equal(length(tab), 14)
+})