# tangram a general purpose table toolkit for R
# Copyright (C) 2017 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/>.
#' Render to LaTeX methods for tangram cell objects
#'
#' Each of these methods will render the cell object as a LaTeX fragment
#'
#' There are addition arguments possible to control the rendering, but
#' due to some oddities between CRAN requirements and how R handles defaults
#' (for full details see the source code)
#' they are as follows
#'
#' * cgroup.just character; The text of the column justification used in the table
#'
#' * arraystretch numeric; The arraystretch parameter used for vertical spacing
#'
#' * style character; can be null or "nejm" for different table styling
#'
#' * rel_size numeric; a scaling to be applied to the entire table, e.g. rel_size=-2
#'
#' * placement character; placement directive, defaults to "H"
#'
#' @param object object; the item to render to latex
#' @param fragment logical; Is this a complete LaTeX document or just the table fragment
#' @param filename character; filename to write LaTex into
#' @param append logical; Should the write be an append operation or overwrite
#' @param na.blank logical; Dispaly NAs as blanks.
#' @param ... additional arguments
#' @return the LaTeX rendering
#' @include compile-cell.R
#' @include render-latex-map.R
#' @examples
#' latex(cell_label("123"))
#' latex(hmisc_iqr(rnorm(20)))
#' latex(hmisc_fraction(45, 137))
#' tbl <- tangram(drug~bili, pbc, "tbl")
#' latex(tbl)
#' @rdname latex
#' @export
latex <- function(object, ...)
{
UseMethod("latex", object)
}
# Helper function to see if in knitr context
# Not perfect, a bit of a hack
# https://stackoverflow.com/questions/33107908/how-to-tell-if-code-is-executed-within-a-knitr-rmarkdown-context
isKnitr <- function()
{
("knitr" %in% .packages()) &&
(isTRUE(getOption('knitr.in.progress')))
}
#' @rdname latex
#' @export
latex.default <- function(object, ...)
{
warning(paste("summary unhandled class : ", paste(base::class(object), collapse=', ')))
latexify(paste0(as.character(object), collapse=" "))
}
#' @rdname latex
#' @export
latex.cell <- function(object, na.blank=TRUE, ...)
{
if(is.logical(object))
{
if(is.na(object))
{
return(if(na.blank) "" else "NA")
} else {
return(as.character(object))
}
}
sep <- if(is.null(attr(object, "sep"))) ", " else attr(object, "sep")
if(is.null(names(object)))
{
latexify(paste(object, collapse=sep))
} else {
name <- vapply(names(object), function(n) if(nchar(n)>0) paste0(n,"=") else "", "character")
latexify(paste(paste0(name, as.character(object)), collapse=sep))
}
}
#' @rdname latex
#' @export
latex.cell_label <- function(object, ...)
{
# Turn "*" for interaction terms into a break
label <- gsub("\\\\\\*", "$\\times$\n\n\u00a0\u00a0", object)
# Turn leading spaces into a set of non breaking html space
label <- gsub("^\\s+", "\u00a0\u00a0\u00a0\u00a0", label)
label <- latexify(label)
if(is.null(attr(object, 'units')))
label
else
paste0(label, " {\\textit{\\relsize{-1} ", latexify(attr(object, 'units')), "}}")
}
#' @rdname latex
#' @export
latex.logical <- function(object, ...)
{
if(is.na(object))
{
NA
} else {
as.character(object)
}
}
#' @rdname latex
#' @export
latex.cell_header <- function(object, ...)
{
cls <- class(object)
class(object) <- cls[2:length(cls)]
paste0("\\textbf{", latex(object, ...), "}")
}
#' @rdname latex
#' @export
latex.cell_subheader <- function(object, ...)
{
cls <- class(object)
class(object) <- cls[3:length(cls)]
paste0("{\\relsize{-1} ", latex(object, ...), "}")
}
#' @rdname latex
#' @export
latex.tangram <- function(object,
fragment=TRUE,
filename=NULL,
append=FALSE,
...)
{
# Nasty Automagic handling of special LaTeX parameters
# Because a tangram object is constructed via a call, that object can be passed to
# a print function in a rendering context and the additional ... arguments are needed.
# These are lost in the REPL and need to be recovered.
# However, someone could call this function directly and those arguments need to take precedence
# Additionally there needs to be defaults for decent default handling.
na.blank <- NULL # These lines are to pass CRAN checks, because it can't fathom assign
cgroup.just <- NULL
arraystretch <- NULL
relsize <- NULL
placement <- NULL
style <- NULL
pandoc_md <- NULL
render_style <- NULL # An override
defaults <- list(
na.blank=TRUE,
cgroup.just=NULL,
arraystretch=1.2,
relsize=0,
placement="H",
style="hmisc",
pandoc_md=FALSE
)
obj.args <- attr(object, "args")
obj.args[["style"]] <- attr(object, "style") # And yet another special case
if("render_style" %in% names(obj.args)) obj.args[["style"]] <- obj.args[["render_style"]]
call.args <- list(...)
if("render_style" %in% names(call.args)) warning("`render_style` argument ignored in direct latex call. Use `style` instead.")
for(i in names(defaults))
{
assign(i,
if(i %in% names(call.args)) { call.args[[i]] } else
if(i %in% names(obj.args)) { obj.args[[i]] } else
{ defaults[[i]] }
)
}
if("pct_width" %in% names(call.args)) stop("tangram now uses longtable and width scaling is no longer supported try relsize=-2")
# Find footnote
footnote <- attr(object, "footnote")
footnote <- if(is.null(footnote)) "" else paste0(latexify(paste0(footnote, collapse="\n\n")), "\n")
# Find caption
caption <- attr(object, "caption")
caption <- if(is.null(caption) || is.na(caption)) "" else latexify(caption)
result <- ""
if(!fragment)
{
result <- paste(result,
"\\documentclass{report}",
"\\usepackage{geometry}",
"\\usepackage[LGR,T1]{fontenc}",
"\\usepackage[utf8]{inputenc}",
"\\usepackage{textgreek}",
"\\usepackage{float}",
"\\usepackage[x11names,dvipsnames,table]{xcolor}",
"\\usepackage{boldline}",
"\\usepackage{multirow}",
"\\usepackage{colortbl}",
"\\usepackage{hhline}",
"\\usepackage{longtable}",
"\\usepackage{relsize}",
"\\begin{document}",
sep="\n")
}
else if(pandoc_md ||isKnitr())
{
result <- paste0(result, "\n```{=latex}\n")
}
if(style=="nejm") result <- paste0(result,
"\\definecolor{nejm-yellow}{RGB}{255,251,237}\n",
"\\definecolor{nejm-header}{RGB}{247,244,239}\n")
if(style=="lancet") result <- paste0(result, "\\definecolor{lancet-red}{RGB}{245,224,220}\n")
if(relsize != 0) result <- paste0(result, "{\\relsize{",relsize,"}\n")
if(style %in% c("nejm", "lancet")) result <- paste0(result, "{\\fontfamily{cmss}\\selectfont\n")
nrows <- rows(object)
ncols <- cols(object)
text <- matrix(data=rep("", nrows*ncols), nrow=nrows, ncol=ncols)
# Render it all
last_header_row <- 0 # Current Header Row
last_header_col <- 0
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
last_header_col <<- col - 1
}
text[row,col] <<- latex(object[[row]][[col]], na.blank, style=style, ...)
colspan <- attr(object[[row]][[col]], "colspan")
if(!is.null(colspan) && colspan > 1)
{
text[row, col] <<- paste0("\\multicolumn{",colspan,"}{c}{", text[row, col], "}")
for(i in (col+1):(col+colspan-1)) object[[row]][[i]] <<- NA
}
rowspan <- attr(object[[row]][[col]], "rowspan")
if(!is.null(rowspan) && rowspan > 1)
{
text[row, col] <<- paste0("\\multirow{",rowspan,"}{*}{", text[row, col], "}")
for(k in (row+1):(row+rowspan-1))
{
object[[k]][[col]] <<- cell(" ")
}
}
})
})
pasty <- apply(text, 1, function(x) paste0(paste(na.omit(x), collapse=" & "), "\\\\\n"))
# Special coloring
if(style=="lancet")
{
for(i in 1:length(pasty))
{
parity <- attr(object[[i]][[1]], "parity")
target <- attr(object[[last_header_row+1]][[1]], "parity")
if(parity == target || i <= last_header_row )
pasty[i] <- paste0("\\rowcolor{lancet-red}", pasty[i])
}
}
if(is.null(cgroup.just)) {
cgroup.just <- paste0(c(rep("l", last_header_col), rep("c", ncols-last_header_col)),collapse="")
if(style=="nejm") cgroup.just <- paste0("|", cgroup.just, "|")
if(style=="lancet") cgroup.just <- paste0("!{\\color{lancet-red}\\vrule width 4pt}", cgroup.just, "!{\\color{lancet-red}\\vrule width 4pt}")
}
result <- paste0(result, "\\renewcommand*{\\arraystretch}{", arraystretch, "}\n")
if(style=="nejm") result <- paste0(result, "\\rowcolors{2}{nejm-yellow}{white}\n")
result <- paste0(result, "\\begin{longtable}[",placement,"]{",cgroup.just,"}\n")
if(caption != "") result <- paste0(result, "\\caption{",caption,"} \\\\ \n")
result <- if(style=="nejm"){
if(caption=="")
paste0(result, "\\hline\\hline\n") else
paste0(result, "\\hline\n\\rowcolor{nejm-header}\\multicolumn{",ncols,"}{|l|}{Table \\thetable{}: ",caption,"} \\\\\n\\hline\n")
} else if(style=="hmisc") {
paste0(result, "\\hline\\hline\n")
} else {
paste0(result, "\n")
}
if(last_header_row > 0) result <- paste0(result, paste0(as.vector(pasty)[1:last_header_row],collapse=""))
if(style=="hmisc") result <- paste0(result, "\\hline\n")
if(style=="lancet") result <- paste0(result, "\\hlineB{2.5}\n")
result <- paste0(result, paste0(as.vector(pasty)[(last_header_row+1):nrows], collapse=''))
if(style=="hmisc") result <- paste0(result, "\\hline\\hline\n")
if(style=="nejm") result <- paste0(result, "\\hline\n")
if(style=="lancet") result <- paste0(result, "\n")
if(nchar(footnote) > 0 && style=="nejm") result <- paste0(result, "\\rowcolor{white}")
if(nchar(footnote) > 0) result <- paste0(result, "\\multicolumn{",ncols,"}{p{0.7\\columnwidth}}{", footnote,"}\n")
result <- paste0(result, "\\end{longtable}\n")
if(relsize != 0) result <- paste0(result, "}\n")
if(style %in% c("nejm","lancet")) result <- paste0(result, "}\n")
if(!fragment)
{
result <- paste0(result, "\\end{document}\n")
} else if(pandoc_md || isKnitr())
{
result <- paste0(result, "```\n\n")
}
result <- gsub("$\\s*$", "", result)
if(!is.null(filename)) cat(result, file=filename, append=append)
class(result) <- c("knit_asis", "latex", "character")
attr(result, "knit_cacheable") <- NA
result
}
#' Return a LaTeX template that works with tangram
#'
#' Pandoc in the current version of RStudio does not allow for setting
#' package options to xcolor and this has made it incompatible with
#' the LaTeX generated by this package. This provides a known
#' working template.
#'
#' An example header would look like the following:
#'
#' ---
#' title: "A Document Full of Beautiful Tables"
#' output:
#' pdf_document:
#' "`r tangram::latex_template()`"
#' ---
#'
#' @return filename of LaTeX template
#' @export
#' @examples
#' latex_template()
#'
latex_template <- function()
{
file.path(system.file(package="tangram"), "extdata", "tex", "tangram.template")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.