#' @importFrom stats setNames
#' @importFrom utils packageVersion
NULL
#' @export
ioslides_plus <- function(logo = NULL,
slide_level = 2,
incremental = FALSE,
fig_width = 7.5,
fig_height = 4.5,
fig_retina = 2,
fig_caption = TRUE,
dev = 'png',
df_print = "default",
smart = TRUE,
self_contained = TRUE,
widescreen = FALSE,
smaller = FALSE,
transition = "default",
mathjax = "default",
analytics = NULL,
template = NULL,
css = NULL,
includes = NULL,
keep_md = FALSE,
lib_dir = NULL,
md_extensions = NULL,
pandoc_args = NULL,
extra_dependencies = NULL,
footer = NULL,
box_colours = NULL,
box_colors = NULL,
...) {
# base pandoc options for all output
args <- c()
library(iosp)
# widescreen
if (widescreen)
args <- c(args, "--variable", "widescreen");
# pagedtables
if (identical(df_print, "paged")) {
extra_dependencies <- append(extra_dependencies,
list(rmarkdown::html_dependency_pagedtable()))
}
# transition
if (is.numeric(transition))
transition <- as.character(transition)
else if (transition %in% c("default", "faster", "slower"))
transition <- switch(transition,
"default" = "0.4",
"faster" = "0.2",
"slower" = "0.6")
else
stop('transition must be "default", "faster", "slower" or a ',
'numeric value (representing seconds)', call. = FALSE)
args <- c(args, rmarkdown::pandoc_variable_arg("transition", transition))
# additional css
for (css_file in css)
args <- c(args, "--css", rmarkdown::pandoc_path_arg(css_file))
# Path to the box_colours css file which is created in the pre_processor
# The file will be removed after knitting
css_colour_file <- NULL
# Path to the logo file (will be updated in the pre_processor)
logo_path <- NULL
# content includes
args <- c(args, rmarkdown::includes_to_pandoc_args(includes))
# template path and assets
if (!is.null(template) && file.exists(template))
args <- c(args, "--template", template)
else
args <- c(args,
"--template",
rmarkdown::pandoc_path_arg(system.file("rmd", "iosp", "default.html", package = "iosp")))
# html dependency for ioslides
extra_dependencies <- append(extra_dependencies,
list(html_dependency_ioslides(),
html_dependency_iosplus()))
# analytics
if (!is.null(analytics))
args <- c(args, rmarkdown::pandoc_variable_arg("analytics", analytics))
# pre-processor for arguments that may depend on the name of the
# the input file (e.g. ones that need to copy supporting files)
pre_processor <- function(metadata, input_file, runtime, knit_meta, files_dir,
output_dir) {
# use files_dir as lib_dir if not explicitly specified
if (is.null(lib_dir))
lib_dir <- files_dir
# extra args
args <- c()
# create the files dir if it doesn't exist
# Expanding the helper function dir_exists() found in util.R (rmarkdown package)
if (!utils::file_test('-d', files_dir))
dir.create(files_dir)
# logo
if (!is.null(logo)) {
logo_path <- logo
if (!self_contained) {
# use same extension as specified logo (default is png if unspecified)
logo_ext <- tools::file_ext(logo)
if (nchar(logo_ext) < 1)
logo_ext <- "png"
logo_path <- file.path(files_dir, paste("logo", logo_ext, sep = "."))
file.copy(from = logo, to = logo_path)
logo_path <<- rmarkdown:::normalized_relative_to(output_dir, logo_path)
} else {
logo_path <<- rmarkdown::pandoc_path_arg(logo_path)
}
args <- c(args, "--variable", paste("logo=", logo_path, sep = ""))
}
# Generate the list of box colours that we ship with iosp
iosp_colours <- list(
red = list(bg = "#ffad99", header_bg = "#991f00"),
green = list(bg = "#adebad", header_bg = "#1f7a1f"),
blue = list(bg = "#99d6ff", header_bg = "#005c99"),
yellow = list(bg = "#ffec8b", header_bg = "#eeb422"),
gray = list(bg = "#fafafa", header_bg = "#cecece"),
white = list(bg = "#ffffff", header_bg = "#cecece"),
cobalt = list(bg = "#2b557a", header_bg = "#002240")
)
# Adding custom colours
if (!is.null(box_colors) && is.null(box_colours)) box_colours <- box_colors
# Trying to lazy load colours
lazy_colours <- unique(sub(".*\\.bg-(\\w+).*", "\\1", grep("\\.bg-(\\w+)", readLines(input_file), value = TRUE)))
# filtering out iosp colours and colours not in colors()
lazy_colours <- lazy_colours[!lazy_colours %in% names(iosp_colours) & lazy_colours %in% colors()]
if (is.list(box_colours)) {
# filtering out colours defined in the header
lazy_colours <- lazy_colours[!lazy_colours %in% sub("^bg-", "", names(box_colours))]
}
box_colours <- c(box_colours, as.list(setNames(lazy_colours, nm = lazy_colours)))
# Allow override of standard iosp colours
box_colours <- c(box_colours, iosp_colours[!names(iosp_colours) %in% names(box_colours)])
if (is.list(box_colours)) {
# Calling unlist followed by as.list to support a single string argument (add_box_colour mandatory argument)
css_content <- lapply(seq_along(box_colours), function(x) {do.call(add_box_colour, as.list(c(names(box_colours)[[x]], unlist(box_colours[[x]]))))})
css_content <- paste(css_content, collapse = "\n")
css_content <- paste("<style type=\"text/css\">", css_content, "</style>", sep = "\n");
css_colour_file <<- file.path(dirname(input_file), "box_colours.css")
tryCatch({
suppressWarnings(writeLines("", css_colour_file, useBytes = TRUE))
},
error = function(...) {
css_colour_file <<- file.path(output_dir, "box_colours.css")
})
writeLines(css_content, css_colour_file, useBytes = TRUE)
args <- c(args, rmarkdown::includes_to_pandoc_args(list(in_header = css_colour_file)))
}
# return additional args
args
}
# post processor that renders our markdown using our custom lua
# renderer and then inserts it into the main file
post_processor <- function(metadata, input_file, output_file, clean, verbose) {
# setup args
args <- c()
# add any custom pandoc args
args <- c(args, pandoc_args)
# Converting md links to html
footer <- gsub("\\[([^\\[\\]\\(\\)]*)\\]\\(([^\\[\\]\\(\\)]*)\\)", "<a href='\\2'>\\1</a>", footer, perl = TRUE)
# Creating html links from urls (http://stackoverflow.com/questions/3809401/what-is-a-good-regular-expression-to-match-a-url)
footer <- gsub("(?<!href=')(https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{2,256}\\.[a-z]{2,6}\\b([-a-zA-Z0-9@:%_\\+.~#?&//=]*))", "<a href=\\1>\\1</a>", footer, perl = TRUE)
# attempt to create the output writer alongside input file
lua_writer <- file.path(dirname(input_file), "ioslides_presentation.lua")
tryCatch({
suppressWarnings(writeLines("", lua_writer, useBytes = TRUE))
},
error = function(...) {
# The input directory may not be writable (on e.g. Shiny Server), so write
# to the output directory in this case. We don't always do this since
# supplying a fully qualified path to the writer can trigger a bug on some
# Linux configurations.
lua_writer <<- file.path(dirname(output_file),
"ioslides_presentation.lua")
})
on.exit(unlink(lua_writer), add = TRUE)
# determine whether we need to run citeproc
input_lines <- readLines(input_file, warn = FALSE)
run_citeproc <- rmarkdown:::citeproc_required(metadata, input_lines)
# write settings to file
settings <- c()
add_setting <- function(name, value) {
settings <<- c(settings, paste("local", name, "=",
ifelse(value, "true", "false")))
}
add_setting("fig_caption", fig_caption)
add_setting("incremental", incremental)
add_setting("smaller", smaller)
add_setting("smart", smart)
add_setting("mathjax", !is.null(mathjax))
# Set level of slide header (used by ioslides_presentation.lua)
settings <- c(settings, sprintf("local slide_level = %s", slide_level))
# Adding footer to lua (paste0 will handle NULL or character(0) better than sprintf)
settings <- c(settings, paste0("local footer = \"", footer, "\""))
if (!is.null(logo_path)) settings <- c(settings, paste0("local logo = \"", logo_path, "\""))
writeLines(settings, lua_writer, useBytes = TRUE)
# For consistency add as pandoc argument
args <- c(args, "--slide-level", as.character(slide_level))
# append main body of script
file.append(lua_writer,
system.file("rmd", "iosp", "ioslides_plus.lua", package = "iosp"))
output_tmpfile <- tempfile("ioslides-output", fileext = ".html")
on.exit(unlink(output_tmpfile), add = TRUE)
on.exit(unlink(css_colour_file), add = TRUE)
# on Windows, cache the current codepage and set it to 65001 (UTF-8) for the
# duration of the Pandoc command. Without this, Pandoc fails when attempting
# to hand UTF-8 encoded non-ASCII characters over to the custom Lua writer.
# See https://github.com/rstudio/rmarkdown/issues/134
if (rmarkdown:::is_windows()) {
# 'chcp' returns e.g., "Active code page: 437"; strip characters and parse
# the number
codepage <- as.numeric(gsub("\\D", "", system2("chcp", stdout = TRUE)))
if (!is.na(codepage)) {
# if we got a valid codepage, restore it on exit
on.exit(system2("chcp", args = codepage, stdout = TRUE), add = TRUE)
# change to the UTF-8 codepage
system2("chcp", args = 65001, stdout = TRUE)
}
}
rmarkdown::pandoc_convert(input = input_file,
to = rmarkdown::relative_to(dirname(input_file), lua_writer),
from = rmarkdown::from_rmarkdown(fig_caption),
output = output_tmpfile,
options = args,
citeproc = run_citeproc,
verbose = verbose)
# read the slides
slides_lines <- readLines(output_tmpfile, warn = FALSE, encoding = "UTF-8")
# base64 encode if needed
if (self_contained) {
slides_lines <- rmarkdown:::base64_encode_images(slides_lines)
}
# read the output file
output_lines <- readLines(output_file, warn = FALSE, encoding = "UTF-8")
# substitute slides for the sentinel line
sentinel_line <- grep("^RENDERED_SLIDES$", output_lines)
if (length(sentinel_line) == 1) {
preface_lines <- c(output_lines[1:sentinel_line[1] - 1])
suffix_lines <- c(output_lines[-(1:sentinel_line[1])])
output_lines <- c(preface_lines, slides_lines, suffix_lines)
writeLines(output_lines, output_file, useBytes = TRUE)
} else {
stop("Slides placeholder not found in slides HTML", call. = FALSE)
}
output_file
}
hook_chunk <- function(x, options) {
# Adapted from the knitr hook_chunk (hooks-md.R)
fence_char = '`'
fence = paste(rep(fence_char, 3), collapse = '')
x = gsub(paste0('[\n]{2,}(', fence, '| )'), '\n\n\\1', x)
# If "row" is set (TRUE or a vector with 2 values), we wrap the chunk in a row.
if (!all(options$echo, options$eval)) {
row <- FALSE
} else if (options$engine == "R" && is.numeric(options$row) && length(options$row) == 2 && sum(options$row) < 13) {
row <- TRUE
col_width <- options$row
} else if (isTRUE(options$row)) {
row <- TRUE
col_width <- c(6, 6)
} else row <- FALSE
# Should I change the following lines and use options$engine instead of the hardcoded r?
if (row) {
# Trying to detect multiple source chunks to place them in different rows
# Matching the fence and extracting positions
m <- gregexpr(paste0("\n([", fence_char, "]{3,})\n+\\1r\n"), x)[[1]]
if (m[1] != -1) {
m <- c(1, m + 4, nchar(x))
x <- lapply(1:(length(m) - 1), function(i) substr(x, m[i], m[i + 1]))
}
# Splitting columns (After the source chunk is closed)
x <- lapply(x, function(s) {p <- regexpr("\n+```[^r]\n+", s) + 4; c(substr(s, 1, p), substr(s, p, nchar(s)))})
if (isTRUE(options$collapse)) {
x <- lapply(1:2, function(i) gsub(paste0('\n([', fence_char, ']{3,})\n+\\1(r)?\n'), "\n", paste0(unlist(lapply(x, `[[`, i)), collapse = "\n")))
x <- paste0("\n<div class = \"col col-", col_width, c(" r-source", " r-output"), "\">\n", x, "\n</div>\n", collapse = "\n")
} else {
x <- lapply(x, function(v) paste0("\n<div class = \"col col-", col_width, c(" r-source", " r-output"), "\">\n", v, "\n</div>\n", collapse = "\n"))
}
}
# If code chunks are present we wrap them in a container div
# Detecting if R source code is present and setting the box class
if (any(grepl("\n+```(r)?\n+", x))) {
options$class <- c("col", paste("col", options$width, sep = "-"), "box", "chunk", "bg-cobalt", options$class)
} else if (options$engine == "css") {
# If it is a css chunk without source we do not want a container around it.
return(paste(x, collapse = "\n"))
}
x <- paste(x, collapse = "\n")
if (!is.null(options$title)) x <- paste0("<h3>", options$title, "</h3>", x)
x <- paste0("\n<div id = \"", options$label, "\" class = \"", paste(options$class, collapse = " "), " \">\n", x, "\n</div>\n")
x = gsub('[\n]+$', '', x)
x = gsub('^[\n]+', '\n', x)
if (is.null(s <- options$indent)) return(x)
knitr:::line_prompt(x, prompt = s, continue = s)
}
knitr = rmarkdown::knitr_options_html(fig_width, fig_height, fig_retina, keep_md, dev)
knitr$knit_hooks$chunk <- hook_chunk
knitr$opts_chunk$comment <- NA
knitr$opts_chunk$width <- 12
knitr$opts_chunk$class <- ""
knitr$opts_chunk$title <- NULL
# return format
rmarkdown::output_format(
knitr = knitr,
pandoc = rmarkdown::pandoc_options(to = "html",
from = rmarkdown::from_rmarkdown(fig_caption, md_extensions),
args = args),
keep_md = keep_md,
clean_supporting = self_contained,
df_print = df_print,
pre_processor = pre_processor,
post_processor = post_processor,
base_format = rmarkdown::html_document_base(smart = smart, lib_dir = lib_dir,
self_contained = self_contained,
mathjax = mathjax,
pandoc_args = pandoc_args,
extra_dependencies = extra_dependencies,
bootstrap_compatible = TRUE, ...))
}
html_dependency_ioslides <- function() {
htmltools::htmlDependency(
name = "ioslides",
version = "13.5.1",
src = system.file("rmd/ioslides/ioslides-13.5.1", package = "rmarkdown"),
script = c(
"js/modernizr.custom.45394.js",
"js/prettify/prettify.js",
#"js/prettify/lang-r.js", # Removing lang-r as we will override it
"js/prettify/lang-yaml.js",
"js/hammer.js",
"js/slide-controller.js",
"js/slide-deck.js"
),
stylesheet = c(
"fonts/fonts.css",
"theme/css/default.css",
"theme/css/phone.css")
)
}
html_dependency_iosplus <- function() {
htmltools::htmlDependency(
name = "iosp",
version = packageVersion("iosp"),
src = system.file("rmd", "iosp", "libs", package = "iosp"),
script = c(
"js/lang-r.js",
"js/slide-deck_oride.js"
),
stylesheet = c(
"css/iosp.css"
)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.