# tangram a general purpose table toolkit for R
# Copyright (C) 2017-2018 Shawn Garbett
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# 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, see <http://www.gnu.org/licenses/>.
#######
#' Generate an Rmd table entry from a cell object
#'
#' Given a cell object generate the corresponding piece of an Rmd table
#'
#' @include compile-cell.R
#' @param object The cell_fstat for indexing
#' @param key A filename to write key values into. Can be false if no key file is desired.
#' @param append logical; Should the key file be appended too, or overwritten
#' @param pad numeric; Minimum width of columns can be a single or vector of numerics.
#' @param ... additional arguments to renderer. Unused
#' @return A string representation of the table
#' @rdname rmd
#' @export
#' @examples
#' rmd(tangram(drug ~ bili, pbc))
rmd <- function(object, key=FALSE, ...)
{
UseMethod("rmd", object)
}
#' @include iify.R
rmdify <- function(x) iify(x, list(
#c(" ", " "),
c("\\\\frac\\{\\s*([^\\}]*)}\\{\\s*([^\\}]*)\\}", "\\1/\\2"),
c(" ", " "),
c("\u03A7", "X")
))
#' @rdname rmd
#' @export
rmd.default <- function(object, key=FALSE, ...) paste0(as.character(object), collapse=", ")
#' @export
#' @rdname rmd
rmd.cell <- function(object, key=FALSE, ...)
{
sep <- if(is.null(attr(object, "sep"))) ", " else attr(object, "sep")
if(is.null(names(object)))
{
paste(object, collapse=sep)
} else {
name <- vapply(names(object), function(n) if(nchar(n)>0) paste0(n,"=") else "", "character")
paste(paste0(name, as.character(object)), collapse=sep)
}
}
#' @export
#' @rdname rmd
rmd.cell_n <- function(object, key=FALSE, ...)
{
rep <- if(key)
{
idx <- index(object, ...)
paste0("((", as.character(object), "))%", word_ref(idx[[1]]), "%")
} else
{
as.character(object)
}
if (inherits(object, "cell_header")) paste0("(N=",rep,")") else rep
}
#' @rdname rmd
#' @export
#'
#' @importFrom stringr str_pad
#' @importFrom utils write.table
rmd.tangram <- function(object, key=NULL, append=FALSE, pad=10, ...)
{
if(!is.null(attr(object, "caption"))) cat('\n', attr(object, "caption"), '\n',sep='')
nrows <- rows(object)
ncols <- cols(object)
text <- matrix(data=rep("", nrows*ncols), nrow=nrows, ncol=ncols)
last_header_row <- 0 # Current Header Row
sapply(1:nrows, FUN=function(row) {
sapply(1:ncols, FUN=function(col) {
if(last_header_row == 0 && !inherits(object[[row]][[col]], "cell_header")) last_header_row <<- row - 1
if(!is.null(attr(object[[row]][[col]], "colspan"))) warning("colspan not supported for Rmd tangram rendering")
if(!is.null(attr(object[[row]][[col]], "rowspan"))) warning("rowspan not supported for Rmd tangram rendering")
text[row,col] <<- rmd(rmdify(object[[row]][[col]]), key=!is.null(key), ...)
})
})
# Pad strings in first row
sapply(1:ncols, FUN=function(col) {
ipad <- if(length(pad) == 1) pad else max(pad[col], 5)
if(is.na(text[1,col]))
{
text[1,col] <<- paste0(rep(" ", ipad), collapse='')
} else if(nchar(text[1,col]) < ipad)
{
text[1,col] <<- str_pad(text[1,col], width=ipad, side="both")
}
})
results <- '\n' # An RMarkdown table must be preceeded by a newline or bad things happen
pasty <- apply(text, 1, function(x) paste(c("|", paste(x, collapse="|"), "|"), collapse=""))
results <- paste0(results, pasty[1], '\n')
results <- paste0(results, sub(":\\|", "-|", gsub("\\|-", "|:", gsub("-\\|", ":|", gsub("[^\\|]", "-", pasty[1])))), '\n')
for(row in pasty[2:nrows]) results <- paste0(results, row, '\n')
if(!is.null(key)) write.table(index(object, ...), key, col.names=FALSE, row.names=FALSE, append=append, sep=",", quote=FALSE)
if(!is.null(attr(object, "footnote")))
{
results <- paste0(results, '\n')
results <- paste0(results, rmdify(paste0(attr(object, "footnote"), collapse="\n")), collapse='\n' )
}
class(results) <- c("knit_asis", "character")
attr(results, "knit_cacheable") <- NA
results
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.