#' Find resource
#' @param type type of resource to find
#' @param fork specify which subdirectory to search in the overall type path
#' @param file file to locate
#' @return absolute path to the resource
find_resource <- function(type = c(
"template_resource",
"template_skeleton",
"global_resource",
"global_font_path"
),
fork,
file) {
type <- match.arg(type)
relative_path <- switch(type,
"template_resource" =
file.path("rmarkdown", "templates", fork, "resources", file),
"template_skeleton" =
file.path("rmarkdown", "templates", fork, "skeleton", "skeleton.Rmd"),
"global_resource" =
file.path("resources", fork, file),
"global_font_path" =
file.path("resources", "fonts")
)
absolute_path <- system.file(relative_path, package = "washu")
if (absolute_path == "") {
stop("Couldn't find resource ", relative_path, call. = FALSE)
}
absolute_path
}
#' TeX setmainfont
#' @param font desired font
#' @param ext font extention
#' @return character vector of TeX code
tex_setmainfont <- function(font = "LibreBaskerville", ext = "ttf") {
c(
"\\usepackage{fontspec}",
sprintf(
"\\setmainfont{%s}[",
font
),
sprintf(
" Path = %s%s ,",
find_resource("global_font_path"),
.Platform$file.sep
),
sprintf(
" Extension = .%s,",
ext
),
" UprightFont = *-Regular,",
" ItalicFont = *-Italic,",
" BoldFont = *-Bold]"
)
}
#' TeX new washulogo command
#' @return character vector of TeX code
tex_washusomlogo <- function() {
sprintf(
"\\newcommand{\\washusomlogo}{%s}",
find_resource("global_resource", "img", "washu_som_logo.eps")
)
}
#' TeX new pigletsignature command
#' @return character vector of TeX code
tex_pigletsignature <- function() {
sprintf(
"\\newcommand{\\pigletsignature}{%s}",
find_resource("template_resource", "letter", "piglet.png")
)
}
#' TeX runtime header additions
#' @param x character vector of TeX code
#' @return path to temporary file containing the TeX code
tex_runtime_in_header <- function(x) {
in_header_path <- file.path(tempdir(), "in_header.tex")
in_header_con <- file(in_header_path)
writeLines(x, in_header_con)
close(in_header_con)
in_header_path
}
#' Letter document
#' Format for creating a WashU letter on School of Medicine letterhead
#' @param template Pandoc template to use for rendering. Passed value ignored
#' in favor of default.
#' @param latex_engine LaTeX engine for producing PDF output. Passed value
#' ignored in favor of default.
#' @inheritParams rmarkdown::pdf_document
#' @param ... Arguments to \code{\link[rmarkdown]{pdf_document}}
#' @export
letter_document <- function(template = find_resource(
"template_resource",
"letter",
"template.tex"
),
latex_engine = "xelatex",
includes,
...) {
runtime_in_header <- tex_runtime_in_header(c(
tex_setmainfont(),
tex_washusomlogo(),
tex_pigletsignature()
))
if (missing(includes)) {
includes <- rmarkdown::includes(runtime_in_header)
} else {
includes$in_header <- append(includes$in_header, runtime_in_header)
}
rmarkdown::pdf_document(
template = find_resource(
"template_resource",
"letter",
"template.tex"
),
latex_engine = "xelatex",
includes = includes,
...
)
}
#' TeX Close Letter
#' @return character vector of TeX code
#' @export
tex_close_letter <- function() {
input <- knitr_current_input()
yaml <- rmarkdown::yaml_front_matter(input)
writeLines(
c(
yaml$closing,
"",
"\\vspace{1\\baselineskip}",
"",
ifelse(
yaml$signature == "",
"\\vspace{1\\baselineskip}",
sprintf(
"\\includegraphics[height=1\\baselineskip]{%s}",
gsub("\\\\", "/", yaml$signature)
)
),
"",
"\\vspace{1\\baselineskip}",
"",
sprintf("%s \\ ", yaml$from$name),
"",
yaml$from$title
)
)
}
#' @inherit knitr::current_input
knitr_current_input <- function(dir = FALSE) {
if (interactive()) {
context <- rstudioapi::getSourceEditorContext()
path <- context$path
if (!is.null(path)) {
ifelse(dir, path, basename(path))
} else {
NULL
}
} else {
knitr::current_input(dir)
}
}
#' Letter of support body
#' @param title title of the project to be supported
#' @param template path to letter of support body template provided by user
#' @param pattern pattern in the file to replace with title
#' @export
letter_of_support_body <-
function(title,
template = Sys.getenv("WU_LETTER_OF_SUPPORT_BODY"),
pattern = "\\$title\\$") {
infile <- file(template)
body <- infile %>%
readLines() %>%
paste(collapse = "\n") %>%
tidy_sub(pattern, title, fixed = FALSE)
close(infile)
body
}
#' New letter of support
#' @param from_name sender name
#' @param from_title sender title
#' @param from_department_type sender department type
#' @param from_department_name sender department name
#' @param from_department_url sender department url
#' @param from_campus_box sender campus box
#' @param from_phone sender phone
#' @param from_email sender email
#' @param to_name recipient name
#' @param to_address recipient address
#' @param date letter date
#' @param salutation letter greeting
#' @param closing letter closing
#' @param body body of letter
#' @param signature path to signature file (empty string for no signature)
#' @param output RMarkdown output
#' @export
#' @examples
#' \dontrun{
#' ## some yaml may require quotes, e.g.:
#' ## - salutation because of the colon
#' ## - signature if spaces in path
#' wu_render_letter_of_support(
#' "Matthew J. Schuelke, PhD",
#' "Research Statistician",
#' "Division",
#' "Biostatistics",
#' "https://biostatistics.wustl.edu",
#' "8067",
#' "+1 314 362-0000",
#' "schuelke@wustl.edu",
#' "Christopher Robin",
#' c("11 Mallord Street", "LONDON", "SW3 6DT", "UK"),
#' Sys.Date(),
#' "\"To Whom It May Concern:\"",
#' "Sincerely,",
#' letter_of_support_body("The Woozle Effect"),
#' paste0("\"", Sys.getenv("WU_SIGNATURE"), "\"")
#' )
#' }
wu_new_letter_of_support <-
function(from_name,
from_title,
from_department_type,
from_department_name,
from_department_url,
from_campus_box,
from_phone,
from_email,
to_name,
to_address,
date,
salutation,
closing,
body,
signature = "",
output = "LOS.Rmd") {
n_to_address_lines <- length(to_address)
to_address[2:n_to_address_lines] <-
paste(" |", to_address[2:n_to_address_lines])
to_address <- paste(to_address, collapse = "\n")
signature <- push_slashes(signature)
infile <- find_resource("template_skeleton", "letter_of_support") %>%
file()
outfile <- output %>%
file()
infile %>%
readLines() %>%
paste(collapse = "\n") %>%
tidy_sub("Piglet", from_name) %>%
tidy_sub("Very Small Animal", from_title) %>%
tidy_sub("Wood", from_department_type) %>%
tidy_sub("Hundred Acre", from_department_name) %>%
tidy_sub("https://hundred.acre.wustl.edu", from_department_url) %>%
tidy_sub("1968", from_campus_box) %>%
tidy_sub("(314) 362-5000", from_phone) %>%
tidy_sub("piglet@wustl.edu", from_email) %>%
tidy_sub("Winnie the Pooh", to_name) %>%
tidy_sub("1 Pooh Corner", to_address) %>%
tidy_sub("14 October 1926", date) %>%
tidy_sub("Hi Pooh,", salutation) %>%
tidy_sub("Your closest friend,", closing) %>%
tidy_sub("piglet.png", signature) %>%
tidy_sub("Thank.+proposal\\.", "$body$", fixed = FALSE) %>%
tidy_sub("$body$", body) %>%
writeLines(outfile)
close(infile)
close(outfile)
}
#' Consult report document
#' Format for converting from R Markdown to a consult report document.
#' @inheritParams rmarkdown::html_document
#' @param ... additional arguments passed to
#' \code{\link[rmarkdown]{html_document}}
#' @details Requires Pandoc version 2.10 or higher for use of
#' --no-check-certificate option.
#' @seealso \url{https://pandoc.org/installing.html}
#' @return R Markdown output format to pass to \code{\link[rmarkdown]{render}}
#' @export
consult_report_document <- function(toc = TRUE,
toc_float = TRUE,
toc_depth = 3,
css,
includes,
pandoc_args,
...) {
# css
new_css <- find_resource(
"template_resource",
"consult_report",
"edu.wustl.biostatistics.css"
)
css <- ifelse(missing(css), new_css, append(css, new_css))
# includes
before_body_addition <- find_resource(
"template_resource",
"consult_report",
"before_body.htm"
)
if (missing(includes)) {
includes <- rmarkdown::includes(before_body = before_body_addition)
} else {
includes$before_body <- append(includes$before_body, before_body_addition)
}
# pandoc_args
# allows get rockwell font on themadstatter.com
# due to pandoc distrust in sectigo as root ca
rmarkdown::pandoc_available("2.10", TRUE)
ncc <- "--no-check-certificate"
pandoc_args <- ifelse(missing(pandoc_args), ncc, append(pandoc_args, ncc))
rmarkdown::html_document(
toc = toc,
toc_float = toc_float,
toc_depth = toc_depth,
css = css,
includes = includes,
pandoc_args = pandoc_args,
...
)
}
#' Estimate document
#' Format for creating a WashU estimate on School of Medicine letterhead
#' @param template Pandoc template to use for rendering. Passed value ignored
#' in favor of default.
#' @param latex_engine LaTeX engine for producing PDF output. Passed value
#' ignored in favor of default.
#' @inheritParams rmarkdown::pdf_document
#' @param ... Arguments to \code{\link[rmarkdown]{pdf_document}}
#' @export
estimate_document <- function(template = find_resource(
"template_resource",
"estimate",
"template.tex"
),
latex_engine = "xelatex",
includes,
...) {
runtime_in_header <- tex_runtime_in_header(c(
tex_setmainfont(),
tex_washusomlogo()
))
if (missing(includes)) {
includes <- rmarkdown::includes(runtime_in_header)
} else {
includes$in_header <- append(includes$in_header, runtime_in_header)
}
rmarkdown::pdf_document(
template = find_resource(
"template_resource",
"estimate",
"template.tex"
),
latex_engine = "xelatex",
includes = includes,
...
)
}
#' Estimate items
#' @param data A data frame, data frame extention (e.g. a tibble), or a lazy
#' data frame (e.g., from dbplyr or dtplyr).
#' @param service description of line item
#' @param hours total hours for the line item
#' @param rate rate per hour for the line item
#' @param .protect flag whether to escape for TeX output
#' @export
estimate_items <- function(data, service, hours, rate, .protect = TRUE) {
est_exprs <- list(
service = rlang::enquo(service) %missing% NA_character_,
hours = rlang::enquo(hours) %missing% NA_character_,
rate = rlang::enquo(rate) %missing% NA_character_
)
out <- dplyr::as_tibble(purrr::map(est_exprs, rlang::eval_tidy, data = data))
structure(out,
preserve = names(est_exprs),
protect = .protect,
class = c("washu_estimate_items", class(data))
)
}
#' Custom S3 Print for washu_estimate_items
#' @param x A washu_estimate_items object to print
#' @param ... additional arguments
#' @importFrom knitr knit_print
#' @export
knit_print.washu_estimate_items <- function(x, ...) {
x[is.na(x)] <- ""
if (!(rlang::`%@%`(x, "protect"))) {
protect_tex_input <- identity # nolint
}
out <- paste0(
" ",
"\\estimateitem{<<protect_tex_input(service)>>}",
"{<<protect_tex_input(hours)>>}",
"{<<protect_tex_input(rate)>>}"
)
out <- glue::glue_data(x, out, .open = "<<", .close = ">>")
knitr::asis_output(
glue::glue_collapse(
c("\\begin{estimate}",
" \\begin{estimatetable}",
out,
" \\end{estimatetable}",
"\\end{estimate}",
sep = "\n"
)
)
)
}
#' Render estimate
#' @param ref,date,description estimate reference, date, and description
#' @param to_name,to_title,to_campus_box,to_email recipient attributes
#' @param from_name,from_title,from_campus_box,from_email sender attributes
#' @param data path to estimate data object containing service, hours, and rate
#' columns
#' @inheritParams rmarkdown::render
#' @param keep_input keep the input document
#' @param ... parameters passed to \code{\link[rmarkdown]{render}}
#' @export
#' @examples
#' \dontrun{
#' ## some yaml may require quotes
#' wu_render_estimate(
#' paste0(Sys.Date(), "-1"),
#' Sys.Date(),
#' "The Woozle Effect",
#' "Christopher Robin",
#' "Billy Moon",
#' "1920",
#' "robin@wustl.edu",
#' "Matthew Schuelke, PhD",
#' "Research Statistician",
#' "8067",
#' "schuelke@wustl.edu",
#' "dat/est.csv"
#' )
#' }
wu_render_estimate <-
function(ref,
date,
description,
to_name,
to_title,
to_campus_box,
to_email,
from_name,
from_title,
from_campus_box,
from_email,
data,
input = "Estimate.Rmd",
keep_input = FALSE,
...) {
infile <- find_resource("template_skeleton", "estimate") %>%
file()
outfile <- input %>%
file()
infile %>%
readLines() %>%
paste(collapse = "\n") %>%
tidy_sub("1926-10-14-1", ref) %>%
tidy_sub("1926-10-14", date) %>%
tidy_sub(
"\"Nothing Every Day: An Inquiry into the Habits of Pooh Bears\"",
description
) %>%
tidy_sub("Winnie the Pooh", to_name) %>%
tidy_sub("Anthropomorphic Bear", to_title) %>%
tidy_sub("1966", to_campus_box) %>%
tidy_sub("pooh@wustl.edu", to_email) %>%
tidy_sub("Piglet", from_name) %>%
tidy_sub("Very Small Animal", from_title) %>%
tidy_sub("1968", from_campus_box) %>%
tidy_sub("piglet@wustl.edu", from_email) %>%
tidy_sub("\n```\\{r\\}\n.+$", "", fixed = FALSE) %>%
append(paste(c(
"```{r, message=FALSE}",
sprintf("read_csv(\"%s\") %%>%%", data),
" estimate_items(service, hours, rate)",
"```"
), collapse = "\n")) %>%
writeLines(outfile)
close(infile)
close(outfile)
rmarkdown::render(input = input, ...)
if (!keep_input) {
if (!file.remove(input)) {
stop("Error deleting skeleton")
}
}
}
#' Insert css code chunk to make consult report document wide
#'
#' @param width_main width in pixels of the main container
#' @param width_tocify width in pixes of the table of contents container
#'
#' @export
css_insert_wide_chunk <- function(width_main = 15000, width_tocify = 400) {
fmt_lines <- c(
"```{css, echo = FALSE}",
"div.main-container {",
" max-width: %ipx;",
"}",
"",
"div.tocify {",
" max-width: %ipx;",
"}",
"```"
)
text <- sprintf(paste(fmt_lines, collapse = "\n"), width_main, width_tocify)
id <- rstudioapi::getSourceEditorContext()$id
invisible(rstudioapi::insertText(text = text, id = id))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.