Merge pull request #62 from RomanTsegelskyi/master

Google Summer of Code 2014 Test Implementation
Rapporter · May 22, 2014 · f437175 · f437175
2 parents f15490b + c31d875
commit f437175
Show file tree

Hide file tree

Showing 4 changed files with 99 additions and 35 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -23,6 +23,7 @@ S3method(pander,option)
 S3method(pander,prcomp)
 S3method(pander,rapport)
 S3method(pander,table)
+S3method(pander,CrossTable)
 export(Pandoc)
 export(Pandoc.brew)
 export(Pandoc.convert)

diff --git a/R/S3.R b/R/S3.R
@@ -378,5 +378,52 @@ pander.POSIXt <- function(x, ...)
     cat(format(x, panderOptions('date')))
 
 #' @S3method pander ftable
-pander.ftable <- function(x,  ...)
+pander.ftable <- function(x, ...)
     pandoc.table(x, ...)
+
+#' @S3method pander CrossTable
+pander.CrossTable <- function(x, caption = attr(x, 'caption'), ...){
+  if (is.null(caption) & !is.null(storage$caption))
+    caption <- get.caption()
+  to.percent <- function(x, digits = 0){
+    paste(round(x * 100, digits), "%",sep="")    
+  }
+  totals <- x$t
+  row.labels <- row.names(totals)
+  col.labels <- colnames(totals)
+  row.size <- length(row.labels)
+  col.size <- length(col.labels)
+  row.name <- x$RowData
+  col.name <- x$ColData  
+  proportion.row <- apply(x$prop.row, c(1,2), to.percent)
+  proportion.column <- apply(x$prop.col, c(1,2), to.percent)
+  proportion.table <- apply(x$prop.tbl, c(1,2), to.percent)
+  row.sum<- x$rs
+  col.sum <- x$cs
+  table.sum <- x$gt
+  zeros <- rep(0, (col.size + 2) * (row.size + 1))
+  constructed.table<- matrix(zeros, ncol=(col.size + 2))
+  constructed.table <- as.table(constructed.table)
+  colnames(constructed.table) <- c("&nbsp;",col.labels,"Total")
+  new.row.labels <- vector()
+  for (i in 1:row.size){
+    constructed.table[i, 1] <- c(new.row.labels, paste(pandoc.strong.return(row.labels[i]), "N", "Row (%)", "Column(%)",sep="\\  \n"))
+    for (j in 2:(col.size + 1)){
+      constructed.table[i, j] <- paste("&nbsp;",totals[i, j - 1],
+                                      proportion.row[i, j - 1],
+                                      proportion.column[i, j - 1],
+                                      proportion.table[i, j - 1], 
+                                      sep="\\ \n")
+    }
+    constructed.table[i, col.size + 2] <- paste("&nbsp;", row.sum[i],
+                                                to.percent(sum(totals[i,]/table.sum)),
+                                                sep="\\ \n")
+  }
+  row.last <- "Total"
+  for (i in 2:(col.size + 1))
+    row.last[i] <- paste(col.sum[i - 1], to.percent(sum(totals[,i - 1])/table.sum), sep="\\ \n")
+  row.last[col.size + 2] <- paste(table.sum, "", sep="\\ \n")
+  constructed.table[row.size + 1, ] <- row.last
+  row.names(constructed.table) <- new.row.labels
+  pandoc.table(constructed.table, caption=caption, keep.line.breaks = TRUE, ...)
+}
diff --git a/R/options.R b/R/options.R
@@ -7,6 +7,7 @@
                 'big.mark'                 = '',
                 'round'                    = Inf,
                 'keep.trailing.zeros'      = FALSE,
+                'keep.line.breaks'         = FALSE,
                 'date'                     = '%Y/%m/%d %X',
                 'header.style'             = 'atx',
                 'list.style'               = 'bullet',
@@ -194,6 +195,7 @@ masked.plots$plot <- masked.plots$barplot <- masked.plots$lines <- masked.plots$
 #'      \item \code{big.mark}: string (default: '') passed to \code{format}
 #'      \item \code{round}: numeric (default: \code{Inf}) passed to \code{round}
 #'      \item \code{keep.trailing.zeros}: boolean (default: \code{FALSE}) to show or remove trailing zeros in numbers
+#'      \item \code{keep.line.breaks}: boolean (default: \code{FALSE}) to keep or remove line breaks from cells in a table
 #'      \item \code{date}: string (default: \code{'\%Y/\%m/\%d \%X'}) passed to \code{format} when printing dates (\code{POSIXct} or \code{POSIXt})
 #'      \item \code{header.style}: \code{'atx'} or \code{'setext'} passed to \code{\link{pandoc.header}}
 #'      \item \code{list.style}: \code{'bullet'}, \code{'ordered'} or \code{'roman'} passed to \code{\link{pandoc.list}}. Please not that this has no effect on \code{pander} methods.

diff --git a/R/pandoc.R b/R/pandoc.R
@@ -1,3 +1,4 @@
+
 #' Indent text
 #'
 #' Indent all (optionally concatenated) lines of provided text with given level.
@@ -448,6 +449,7 @@ pandoc.list <- function(...)
 #' @param split.tables where to split wide tables to separate tables. The default value (\code{80}) suggests the conventional number of characters used in a line, feel free to change (e.g. to \code{Inf} to disable this feature) if you are not using a VT100 terminal any more :)
 #' @param split.cells where to split cells' text with line breaks. Default to \code{30}, to disable set to \code{Inf}.
 #' @param keep.trailing.zeros to show or remove trailing zeros in numbers on a column basis width
+#' @param keep.line.breaks to keep or remove line breaks from cells in a table
 #' @param emphasize.rows a vector for a two dimensional table specifying which rows to emphasize
 #' @param emphasize.cols a vector for a two dimensional table specifying which cols to emphasize
 #' @param emphasize.cells a vector for one-dimensional tables or a matrix like structure with two columns for row and column indexes to be emphasized in two dimensional tables. See e.g. \code{which(..., arr.ind = TRUE)}
@@ -490,7 +492,7 @@ pandoc.list <- function(...)
 #' pandoc.table(mtcars, caption = 'Only once after the first part!')
 #'
 #' ## tables with line breaks in cells
-#' ## NOTE: line breaks are removed from table content
+#' ## NOTE: line breaks are removed from table content in case keep.line.breaks is set to FALSE
 #' ## and added automatically based on "split.cells" parameter!
 #' t <- data.frame(a = c('hundreds\nof\nmouses', '3 cats'), b=c('FOO is nice', 'BAR\nBAR2'))
 #' pandoc.table(t)
@@ -521,7 +523,7 @@ pandoc.list <- function(...)
 #'
 #' emphasize.strong.cells(which(t > 20, arr.ind = TRUE))
 #' pandoc.table(t)
-pandoc.table.return <- function(t, caption, digits = panderOptions('digits'), decimal.mark = panderOptions('decimal.mark'), big.mark = panderOptions('big.mark'), round = panderOptions('round'), justify, style = c('multiline', 'grid', 'simple', 'rmarkdown'), split.tables = panderOptions('table.split.table'), split.cells = panderOptions('table.split.cells'), keep.trailing.zeros = panderOptions('keep.trailing.zeros'), emphasize.rows, emphasize.cols, emphasize.cells, emphasize.strong.rows, emphasize.strong.cols, emphasize.strong.cells, ...) {
+pandoc.table.return <- function(t, caption, digits = panderOptions('digits'), decimal.mark = panderOptions('decimal.mark'), big.mark = panderOptions('big.mark'), round = panderOptions('round'), justify, style = c('multiline', 'grid', 'simple', 'rmarkdown'), split.tables = panderOptions('table.split.table'), split.cells = panderOptions('table.split.cells'), keep.trailing.zeros = panderOptions('keep.trailing.zeros'), keep.line.breaks = panderOptions('keep.line.breaks'), emphasize.rows, emphasize.cols, emphasize.cells, emphasize.strong.rows, emphasize.strong.cols, emphasize.strong.cells, ...) {
 
     ## helper functions
     table.expand <- function(cells, cols.width, justify, sep.cols) {
@@ -546,42 +548,54 @@ pandoc.table.return <- function(t, caption, digits = panderOptions('digits'), de
         }
 
     }
+    split.line <- function(x){
+      split <- strsplit(x, '\\s')[[1]]
+      n <- nchar(split[1], type = 'width')
+      x <- split[1]
+      if (is.na(x))   # case of when line starts with a line break
+        x <- ''
+      for (s in tail(split, -1)) {
+        if (s == "") # for case of when keeping line breaks, strsplit returns empty lines
+          next 
+        nc <- nchar(s, type = 'width')
+        n  <- n + nc + 1
+        if (n > split.cells) {
+          n <- nc
+          x <- paste(x, s, sep = '\n')
+        } else {
+          x <- paste(x, s, sep = ' ')
+        }
+      }
+      x
+    }
+
     split.large.cells <- function(cells)
         sapply(cells, function(x) {
-
-            if (!style %in% c('simple', 'rmarkdown')) {
-
-                ## split
-                if (nchar(x) == nchar(x, type = 'width')) {
-
-                    x <- paste(strwrap(x, width = split.cells), collapse = '\n')
-
-                } else {
-
-                    ## dealing with CJK chars
-                    split <- strsplit(x, '\\s')[[1]]
-                    n <- nchar(split[1], type = 'width')
-                    x <- split[1]
-                    for (s in tail(split, -1)) {
-                        nc <- nchar(s, type = 'width')
-                        n  <- n + nc + 1
-                        if (n > split.cells) {
-                            n <- nc
-                            x <- paste(x, s, sep = '\n')
-                        } else {
-                            x <- paste(x, s, sep = ' ')
-                        }
-                    }
+          if (!style %in% c('simple', 'rmarkdown')) {
+            ## split
+            if (nchar(x) == nchar(x, type = 'width')) {
+              x <- paste(strwrap(x, width = split.cells), collapse = '\n')
+            } else {                
+              ## dealing with CJK chars + also it does not count \n, \t, etc.
+              ## this happens because width - counts only the number of columns 
+              ## cat will use to print the string in a monospaced font. 
+              if (!keep.line.breaks){
+                x <- split.line(x)
+              } else {
+                lines <- strsplit(x, '\\n')[[1]]
+                x <- ""
+                for (line in lines){
+                  sl <- split.line(line)    
+                  x <- paste0(x, sl, sep="\n")
                 }
-
+              }
             }
-
-            ## return
-            if (x == 'NA')
-                ''
-            else
-                x
-
+          }
+          ## return
+          if (is.na(x))
+            ''
+          else
+            x
         }, USE.NAMES = FALSE)
     align.hdr <- function(t.width, justify) {
         justify.vec <- rep(justify, length.out = length(t.width))