Nothing
# Project: pkgmaker
#
# Author: renaud gaujoux
# Created: Oct 23, 2013
###############################################################################
#' Knitr Extensions
#'
#' \code{knit_ex} is a utility function for running small knitr examples,
#' e.g., to illustrate functionalities or issues.
#'
#' @param x text to knit as a character vector
#' @param ... arguments passed to \code{\link[knitr]{knit2html}} or \code{\link[knitr]{knit}}
#' @param quiet logical that indicates if knitting should be quiet (no progress bars etc..).
#' @param open logical, only used when \code{x} is in .Rmd format, that indicates
#' if the generated document result should be open in a browse, instead of
#' being printed on screen.
#' Not that a browser will not open in non-interactive sessions, and the result will
#' be returned invisibly.
#'
#' @return
#' \code{knit_ex} returns the generated code, although invisibly when \code{open=TRUE}.
#'
#' @export
#' @examples
#'
#' library(knitr)
#' knit_ex("1 + 1")
#'
knit_ex <- function(x, ..., quiet = TRUE, open = FALSE){
if( !requireNamespace('knitr', quietly = TRUE) )
stop("Package 'knitr' is required to run knit_ex.")
# substitute special markup for Rmd markup (necessary for knit_ex examples)
x <- gsub("^^^", "```", x, fixed = TRUE)
if( !(html_chunks <- any(grepl("```{", x, fixed = TRUE))) ){
if( all(!grepl(">>=", x, fixed = TRUE)) ){
x <- c("```{r}", x, "```")
html_chunks <- TRUE
}
}
x <- paste0(x, collapse = "\n")
if( any(html_chunks) ){
res <- knitr::knit2html(text = x, ..., template = FALSE, quiet = quiet)
if( open ){
tmp <- tempfile("knit_ex", fileext = '.html')
cat(res, file = tmp, sep = "\n")
if( interactive() ) browseURL(tmp)
return(invisible(res))
}
}else{
res <- knitr::knit(text = x, ..., quiet = quiet)
}
cat(res)
}
try_message <- function(signal = FALSE){
function(expr){
tryCatch(expr, error = function(e){
if( signal ) message(e)
else message('Error: ', conditionMessage(e))
invisible()
})
}
}
#' @describeIn knit_ex is a knitr hook to enable showing error
#' messages thrown by \code{\link{try}}.
#' The function is not meant to be called directly, but only registered
#' using [knitr::knit_hooks] (see details on this dedicated man page).
#'
#' This simply defines a function \code{try} in \code{envir} that prints
#' the error message if any, and is called instead of base \code{\link{try}}.
#'
#' @param before logical that indicates when the hook is being called:
#' before or after the chunk is processed.
#' @param options list of current knitr chunk options
#' @param envir environment where the chunk is evaluated
#'
#' @return * `hook_try` returns a function.
#' @export
#' @examples
#'
#' library(knitr)
#'
#' # standard error message is caught
#' knit_ex("stop('ah ah')")
#'
#' # with try the error is output on stderr but not caughted by knitr
#' knit_ex("try( stop('ah ah') )")
#'
#' \donttest{
#' # no message caught
#' knit_ex("
#' ^^^{r, include = FALSE}
#' knit_hooks$set(try = pkgmaker::hook_try)
#' ^^^
#'
#' ^^^{r, try=TRUE}
#' try( stop('ah ah') )
#' ^^^")
#' }
#'
hook_try <- local({
.try_defined <- FALSE
function(before, options, envir){
# remove hacked version of try
if( !before ){
if( .try_defined && exists('try', envir = envir, inherits = FALSE) ){
remove(list = 'try', envir = envir)
}
.try_defined <<- FALSE
return(invisible())
}
if( !is.null(options$try) ){
# signal
do.signal <- isFALSE(options$try)
if( isManualVignette() && isTRUE(options$try) ){
do.signal <- TRUE
}
# define hacked version of try()
.try <- try_message(do.signal)
assign('try', .try, envir)
.try_defined <<- TRUE
}
}
})
chunkOutputHook <- function(name, hook, type = c('output', 'source', 'chunk')){
type <- match.arg(type)
function(){
if( !requireNamespace('knitr', quietly = TRUE) )
stop("Package 'knitr' is required to setup knit hook '", name, "'")
.hook_bkp <- NULL
function(before, options, envir){
# do nothing if the option is not ON
if( is.null(options[[name]]) ) return()
# set/unset hook
if( before ){
# store current hook function
if( is.null(.hook_bkp) ) .hook_bkp <<- knitr::knit_hooks$get(type)
# define hook wrapper
hook_wrapper <- function(x, options){
res <- .hook_bkp(x, options)
hook(res, options)
}
args <- list()
args[[type]] <- hook_wrapper
do.call(knitr::knit_hooks$set, args)
}else{
args <- list()
args[[type]] <- .hook_bkp
do.call(knitr::knit_hooks$set, args)
.hook_bkp <<- NULL
}
}
}
}
#' Knitr Hook for Handling Backspace Character
#'
#' \code{hook_backspace} is a chunk hook that enables the use of backspace
#' characters in the output (e.g., as used in progress bars), and still
#' obtain a final output as in the console.
#'
#' @return * `hook_backspace` returns a function.
#' @rdname knit_ex
#' @export
#' @examples
#'
#' \donttest{
#' # Correctly formatting backspaces in chunk outputs
#' tmp <- tempfile(fileext = '.Rmd')
#' cat(file = tmp, "
#' ^^^{r, include = FALSE}
#' library(knitr)
#' knit_hooks$set(backspace = pkgmaker::hook_backspace())
#' ^^^
#' Default knitr does not handle backspace and adds a special character:
#' ^^^{r}
#' cat('abc\bd')
#' ^^^
#'
#' Using the hook backspace solves the issue:
#' ^^^{r, backspace=TRUE}
#' cat('abc\bd')
#' ^^^
#' ")
#'
#' # knit
#' out <- knitr::knit2html(tmp, template = FALSE)
#'
#' }
#'
#' # look at output
#' \dontrun{
#' browseURL(out)
#' edit( file = out)
#' }
#'
#' \donttest{
#' # cleanup
#' out_files <- list.files(dirname(out), full.names = TRUE,
#' pattern = paste0("^", tools::file_path_sans_ext(out)))
#' unlink(c(tmp, out_files))
#' }
#'
#'
hook_backspace <- chunkOutputHook('backspace',
function(x, options){
if( !isTRUE(options$backspace) ) x
str_bs(x)
}
)
#' @describeIn str_out substitutes backspace characters (`\\b`) to produce
#' a character string as it would be displayed in the console.
#'
#' @author
#' Renaud Gaujoux
#'
#' \code{str_bs} was adapted from a proposal from Yihui Xie.
#'
#' @return * `str_bs` returns a character string.
#' @export
#' @examples
#'
#' # Backspace substitution
#' str_bs("abc")
#' str_bs("abc\b")
#' str_bs("abc\b\b")
#' str_bs("abc\bd")
#' str_bs("abc\b\bde\b")
#'
#' # more complex example
#' x <- "\bab\nc\bd\n\babc\b\bd"
#' cat(x, "\n")
#' y <- str_bs(x)
#' y
#' cat(y, "\n")
#'
str_bs <- function(x){
# remove leading backspaces
x <- gsub("^\b+", "", x)
# remove backspaces at beginning of line
x <- gsub("\n\b+", '\n', x)
while( length(grep('\b', x, fixed = TRUE)) )
x <- gsub('[^\n\b][\b]', '', x)
x
}
md_toggleCode <- function(){
cat(
"
<script src=\"http://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js\"></script>
<script type=\"text/javascript\">
// toggle visibility of R source blocks in R Markdown output
function toggle_vis(o) {
var d = o.style.display;
o.style.display = (d == 'block' || d == '') ? 'none':'block';
}
function toggle_R(what) {
var x = document.getElementsByClassName('r');
if (x.length == 0) return;
for (i = 0; i < x.length; i++) {
var y = x[i];
switch (y.tagName.toLowerCase()) {
case 'pre':
toggle_vis(y);
if( what == 'setup' ){
y.id = \"Rcode_\" + i;
}
break;
case 'code':
var z = y.parentNode;
// pandoc uses the class 'sourceCode r' on both pre and code
if (z.tagName.toLowerCase() == 'pre' && z.className != 'sourceCode r') {
toggle_vis(z);
if( what == 'setup' ){
z.id = \"Rcode_\" + i;
var newContent = $(\"<a href=\\\"\\\" onclick=\\\"toggle_vis(document.getElementById('\" + z.id + \"')); return false;\\\">Show/Hide R code</a>\");
newContent.insertBefore(z);
}
}
break;
}
}
}
$( document ).ready(function(){
toggle_R('setup');
});
</script>"
)
}
.js_include_jquery <- "<script src=\"http://ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min.js\"></script>\n"
.js_toggle_fun <- "<script type=\"text/javascript\">
function toggle_vis2(cl) {
elt = document.getElementsByClassName(cl)
for (i = 0; i < elt.length; i++) {
var o = elt[i].parentNode;
var d = o.style.display;
o.style.display = (d == 'block' || d == '') ? 'none':'block';
}
}
window.onload = function(){
toggle_vis2('Chunk_none')
}
</script>
"
.js_def_toggle_code <- "<script type=\"text/javascript\">
// toggle visibility of R source blocks in R Markdown output
function toggle_R(what) {
var x = document.getElementsByClassName('r');
if (x.length == 0) return;
function toggle_vis(o) {
var d = o.style.display;
o.style.display = (d == 'block' || d == '') ? 'none':'block';
}
for (i = 0; i < x.length; i++) {
var y = x[i];
switch (y.tagName.toLowerCase()) {
case 'pre':
toggle_vis(y);
if( what == 'setup' ){
y.id = \"Rcode_\" + i;
}
break;
case 'code':
var z = y.parentNode;
// pandoc uses the class 'sourceCode r' on both pre and code
if (z.tagName.toLowerCase() == 'pre' && z.className != 'sourceCode r') {
toggle_vis(z);
if( what == 'setup' ){
z.id = \"Rcode_\" + i;
var newContent = $(\"<a href=\\\"\\\" onclick=\\\"$('#\" + z.id + \"').toggle(); return false;\\\">Show/Hide R code</a>\");
newContent.insertBefore(z);
}
}
break;
}
}
}
$( document ).ready(function(){
toggle_R('setup');
});
</script>"
#' @describeIn knit_ex a chunk hook that adds clickable elements to toggle \emph{indvidual}
#' code chunks in HTML documents generated from .Rmd files.
#'
#' @return * `hook_toggle`: returns a hook function.
#' @export
#' @examples
#'
#' \donttest{
#'
#' knit_ex("
#'
#' Declare chunk hook:
#' ^^^{r, setup}
#' library(knitr)
#' knit_hooks$set(toggle = hook_toggle())
#' ^^^
#'
#' The R code of this chunk can be toggled on/off, and starts visible:
#' ^^^{r, toggle=TRUE}
#' print(1:10)
#' ^^^
#' The R code of this chunk can be toggled on/off, and starts hidden:
#' ^^^{r, toggle=FALSE}
#' print(1:10)
#' ^^^
#'
#' This is a plain chunk that cannot be toggled on/off:
#' ^^^{r}
#' print(1:10)
#' ^^^
#'
#' Now all chunks can be toggled and start visible:
#' ^^^{r, toggle_all}
#' opts_chunk$set(toggle = TRUE)
#' ^^^
#'
#' ^^^{r}
#' sample(5)
#' ^^^
#'
#' To disable the toggle link, one can pass anything except TRUE/FALSE:
#' ^^^{r, toggle = NA}
#' sample(5)
#' ^^^
#'
#' ", open = FALSE)
#'
#' }
#'
hook_toggle <- function(){
.init <- TRUE
.last_label <- NULL
fn <- chunkOutputHook('toggle', type = 'source', function(x, options){
opt <- options$toggle
label <- options$label
if( !isTRUE(opt) && !isFALSE(opt) ) return(x)
# print(x)
# x <- gsub("^\n", '', x)
# add javascript define for toggle function
if( .init ){
x <- paste0(.js_toggle_fun, x)
.init <<- FALSE
}
disp <- if( opt ) 'Chunk_block'
else 'Chunk_none'
id <- paste0("Rcode_", label)
subst <- paste0("```{", id, " \\1 ", disp, "}\n")
if( !identical(label, .last_label) ){
.last_label <<- label
subst <- paste0("<a href=\"\" onclick=\"toggle_vis2('", id, "'); return false;\">Show/Hide R code</a>\n", subst)
}
sub("```([^\n]*)\n", subst, x)
})
fn()
}
# adapted from rmarkdown:::merge_lists
# added capability of appending instead of just replacing value
.merge_lists <- local({
.depth <- -1L
function (base_list, overlay_list, recursive = TRUE)
{
# track depth
.depth <<- .depth + 1L
on.exit( .depth <<- .depth - 1L)
res <-
if (length(base_list) == 0)
overlay_list
else if (length(overlay_list) == 0)
base_list
else {
merged_list <- base_list
for (name in unique(names(overlay_list)) ) {
base <- base_list[[name]]
overlay <- overlay_list[[name]]
if (is.list(base) && is.list(overlay) && recursive)
merged_list[[name]] <- .merge_lists(base, overlay)
else {
merged_list[[name]] <- NULL
merged_list <- append(merged_list, overlay_list[which(names(overlay_list) %in%
name)])
}
}
merged_list
}
# merge append/prepend special fields
if( .depth == 0L && length(specials <- grep("[<>]$", names(res), value = TRUE)) ){
lapply(specials, function(s){
n <- gsub("[<>]$", "", s)
if( grepl("<$", s) ){ # append
res[[n]] <<- c(res[[n]], res[[s]])
}else{ # prepend
res[[n]] <<- c(res[[s]], res[[n]])
}
})
res[specials] <- NULL
}
res
}
})
parse_yaml_front_matter2 <- local({
.parse_yaml_front_matter <- NULL
.config <- NULL
.output_format <- NULL
.output_options <- NULL
function(input_lines, config = NULL, output_options = NULL, output_format = NULL){
requireNamespace('yaml')
merge_lists <- .merge_lists
if( is.null(.parse_yaml_front_matter) ){
env <- environment(rmarkdown::render)
.parse_yaml_front_matter <<- env$parse_yaml_front_matter
}
if( !nargs() ) return(.parse_yaml_front_matter)
if( !missing(config) ) .config <<- config
if( !missing(output_format) ) .output_format <<- output_format
if( !missing(output_options) ) .output_options <<- output_options
if( missing(input_lines) ) return(parse_yaml_front_matter2)
.config <- .config %||%
(if( file.exists(default_config <- '~/.rmarkdown.yaml') ) default_config) %||%
read.yaml_section('rmarkdown::render') # section in .Rprofile
if( isString(.config) ){
.config <- yaml::yaml.load_file(.config)
}
# use this trick to avoid spurious NOTE in check
yaml_front_matter_parser <- .parse_yaml_front_matter
metadata <- yaml_front_matter_parser(input_lines)
if( !is.null(.output_options) ){
metadata <- merge_lists(metadata, .output_options)
}
if( !is.list(.config) ) return(metadata)
m <- merge_lists(.config, metadata)
if( isString(m$output) )
m$output <- setNames(list(list()), m$output)
of <- .output_format %||% names(m$output)[1L] %||% 'html_document'
if( isString(of) && !is.null(.config$output[[of]]) )
m$output <- merge_lists(m$output[[of]], .config$output[of])
m
}
})
# initialize front_matter parser override if possible
#if( requireNamespace('rmarkdown', quietly = TRUE) ){
# parse_yaml_front_matter2()
#}
#' Renders rmarkdown Documents Using User Default Options
#'
#'
#' @inheritParams rmarkdown::render
#' @param ... other arguments passed to \code{\link[rmarkdown]{render}}
#' @param .config location of the default options (a YAML file).
#' Default behaviour is to look for file \code{'.rmarkdown.yaml'} in the user's
#' home directory, or, if missing, for a yaml section \code{rmarkdown::render}
#' in the user's R profile.
#'
#' @return the path to the rendered file, like [rmarkdown::render].
#' @seealso \code{\link{read.yaml_section}}
#' @export
render_notes <- function(input, output_format = NULL, output_options = NULL, ..., .config = NULL){
mrequire("to render documents", 'rmarkdown')
requireNamespace('rmarkdown')
# initial call to initialise override and backup
parse_yaml_front_matter2()
if( is.null(output_format) ){
# parse using original rmarkdown parser
doc_matter <- parse_yaml_front_matter2()(readLines(input))
output_format <- names(doc_matter$output)[1L] %||% doc_matter$output
if( is.null(output_format) ){
fmt <- list(html = c('r', 'rmd', 'md'), pdf = 'rnw')
ext <- tolower(file_extension(input))
output_format <- setNames(rep(names(fmt), sapply(fmt, length)), unlist(fmt))[ext]
if( is_NA(output_format) ) output_format <- NULL
if( ext == 'rnw' ){
input0 <- normalizePath(input)
tmpinput <- tempfile(paste0(basename(input0), '_'), dirname(input0))
tmpinput_file <- paste0(tmpinput, ".", ext)
# chunk out preamble and add it as an option
l <- str_trim(readLines(input))
if( length(i0 <- grep("^[^%]*[\\]documentclass *((\\[)|(\\{))", l)) ){
i1 <- grep("^[^%]*[\\]begin *\\{ *document *\\}", l)
preamb <- l[seq(i0, i1)]
tmpinput_header <- paste0(tmpinput, "_preamble.tex")
cat(preamb[c(-1, -length(preamb))], file = tmpinput_header, sep = "\n")
output_options <- output_options %||% list()
output_options$includes$in_header <- tmpinput_header
l <- l[-seq(i0, i1)]
on.exit({
if( is.dir(tmp_fdir <- paste0(tmpinput, '_files')) ){
fdir <- paste0(input0, '_files')
unlink(fdir, recursive = TRUE)
file.rename(tmp_fdir, fdir)
}
unlink(tmpinput_header)
unlink(tmpinput_file)
}, add = TRUE)
cat(l, file = tmpinput_file, sep = "\n")
input <- tmpinput_file
}
}
}
}
# enforce suffix '_document'
if( isString(output_format) )
if( !grepl("_", output_format, fixed = TRUE) ){
output_type <- gsub("_((document)|(presentation))$", '', tolower(output_format))
if( output_type %in% c('beamer') ) output_format <- paste0(output_type, '_presentation')
else output_format <- paste0(output_type, '_document')
}
is_output_format <- ns_get('is_output_format', 'rmarkdown')
if( !is_output_format(output_format) ){
output_format_from_yaml_front_matter <- ns_get('output_format_from_yaml_front_matter', 'rmarkdown')
output_format <- output_format_from_yaml_front_matter(readLines(input), output_format_name = output_format)
output_format <- output_format$name
}
# hook wrapper in render environment
env <- environment(rmarkdown::render)
do.call("unlockBinding", list("parse_yaml_front_matter", env))
# restore on exit
on.exit({
if( bindingIsLocked("parse_yaml_front_matter", env) )
do.call("unlockBinding", list("parse_yaml_front_matter", env))
env$parse_yaml_front_matter <- parse_yaml_front_matter2()
lockBinding("parse_yaml_front_matter", env)
}, add = TRUE)
# override function
env$parse_yaml_front_matter <- parse_yaml_front_matter2(config = .config, output_options = output_options, output_format = output_format)
# lock it again
lockBinding("parse_yaml_front_matter", env)
# classic render
rmarkdown::render(input, output_format, output_options = output_options, ...)
}
#user_document <- local({
# ..config <- ..output_format <- NULL
# function(..., .config, .output_format = NULL){
#
# if( !missing(.config) ){
# if( is.null(.output_format) ) .output_format <- 'html'
# ..output_format <<- .output_format
# ..config <<- .config
# return()
# }
#
# of <- ..output_format
# if( isString(of) ){
# # call wrapped output format function
# e <- parent.frame()
# of <- getFunction(paste0(gsub("_document$", '', tolower(of)), '_document'), where = e)
# }
# if( is.function(of) ) of <- of(...)
#
# # wrap pre-processor
# .pre_processor <- of$pre_processor
# .set_render_metadata_defaults <- function(value){
#
# env <- environment(rmarkdown::render)
# old_value <- env$metadata
# #do.call("unlockBinding", list("metadata", env))
# #on.exit( lockBinding("metadata", env) )
# env$metadata <- value
#
# old_value
# }
#
# of$pre_processor <- function(metadata, ...){
# # merge and change metadata in render environment
# metadata <- rmarkdown:::merge_lists(..config, metadata)
# .set_render_metadata_defaults(metadata)
# .pre_processor(metadata, ...)
# }
#
# of
# }
#})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.