1#' Convert to an HTML notebook 2#' 3#' Format for converting from R Markdown to an HTML notebook. 4#' 5#' See the \href{https://rmarkdown.rstudio.com/r_notebook_format.html}{online 6#' documentation} for additional details on using the \code{html_notebook} 7#' format. 8#' @inheritParams html_document 9#' @param output_source Define an output source for \R chunks (ie, 10#' outputs to use instead of those produced by evaluating the 11#' underlying \R code). See \code{\link{html_notebook_output}} for 12#' more details. 13#' @param self_contained Produce a standalone HTML file with no external 14#' dependencies. Defaults to \code{TRUE}. In notebooks, setting this to 15#' \code{FALSE} is not recommended, since the setting does not apply to 16#' embedded notebook output such as plots and HTML widgets. 17#' @importFrom evaluate evaluate 18#' @export 19html_notebook <- function(toc = FALSE, 20 toc_depth = 3, 21 toc_float = FALSE, 22 number_sections = FALSE, 23 fig_width = 7, 24 fig_height = 5, 25 fig_retina = 2, 26 fig_caption = TRUE, 27 code_folding = "show", 28 theme = "default", 29 highlight = "textmate", 30 mathjax = "default", 31 extra_dependencies = NULL, 32 css = NULL, 33 includes = NULL, 34 md_extensions = NULL, 35 pandoc_args = NULL, 36 output_source = NULL, 37 self_contained = TRUE, 38 ...) 39{ 40 # some global state that is captured in pre_knit 41 exit_actions <- list() 42 on_exit <- function() { 43 for (action in exit_actions) 44 try(action()) 45 } 46 47 paged_table_html_asis = function(x) { 48 knitr::asis_output( 49 paged_table_html(x) 50 ) 51 } 52 53 # define pre_knit hook 54 pre_knit <- function(input, ...) { 55 56 if (is.function(output_source)) { 57 58 # pull out 'output_source' 59 validate_output_source(output_source) 60 61 # force knitr labeling (required for uniqueness of labels + cache coherence) 62 knitr.duplicate.label <- getOption("knitr.duplicate.label") 63 if (identical(knitr.duplicate.label, "allow")) { 64 warning("unsetting 'knitr.duplicate.label' for duration of render") 65 options(knitr.duplicate.label = "deny") 66 exit_actions <<- c(exit_actions, function() { 67 options(knitr.duplicate.label = knitr.duplicate.label) 68 }) 69 } 70 71 # force default unnamed chunk labeling scheme (for cache coherence) 72 unnamed.chunk.label <- knitr::opts_knit$get("unnamed.chunk.label") 73 if (!identical(unnamed.chunk.label, "unnamed-chunk")) { 74 warning("reverting 'unnamed.chunk.label' to 'unnamed-chunk' for duration of render") 75 knitr::opts_knit$set(unnamed.chunk.label = "unnamed-chunk") 76 exit_actions <<- c(exit_actions, function() { 77 knitr::opts_knit$set(unnamed.chunk.label = unnamed.chunk.label) 78 }) 79 } 80 81 # if our output_source comes with a pre_knit hook, evaluate that 82 output_source_pre_knit <- attr(output_source, "pre_knit", exact = TRUE) 83 if (is.function(output_source_pre_knit)) 84 try(output_source_pre_knit()) 85 86 # track knit context 87 chunk_options <- list() 88 89 # use an 'include' hook to track chunk options (any 90 # 'opts_hooks' hook will do; we just want this to be called 91 # on entry to any chunk) 92 include_hook <- knitr::opts_hooks$get("include") 93 exit_actions <<- c(exit_actions, function() { 94 knitr::opts_hooks$set( 95 include = if (is.null(include_hook)) { 96 function(options) options 97 } else { 98 include_hook 99 } 100 ) 101 }) 102 103 knitr::opts_hooks$set(include = function(options) { 104 105 # save context 106 chunk_options <<- options 107 108 # force R engine (so that everything goes through evaluate 109 # hook and hence 'output_source') 110 options$engine <- "R" 111 options$engine.opts <- NULL 112 113 # disable caching 114 options$cache <- FALSE 115 116 # call original hook 117 if (is.function(include_hook)) 118 include_hook(options) 119 else 120 options 121 }) 122 123 # set up evaluate hook (override any pre-existing evaluate hook) 124 evaluate_hook <- knitr::knit_hooks$get("evaluate") 125 exit_actions <<- c(exit_actions, function() { 126 knitr::knit_hooks$set(evaluate = evaluate_hook) 127 }) 128 129 knitr::knit_hooks$set(evaluate = function(code, ...) { 130 chunk_options <- merge_render_context(chunk_options) 131 context <- list2env(chunk_options) 132 output <- output_source(code, context, ...) 133 as_evaluate_output(output, context, ...) 134 }) 135 } 136 137 # set large max.print for knitr sql engine (since we will give 138 # it a scrolling treatment) 139 knit_sql_max_print <- knitr::opts_knit$get('sql.max.print'); 140 if (is.null(knit_sql_max_print)) { 141 knitr::opts_knit$set(sql.max.print = 1000) 142 exit_actions <<- c(exit_actions, function() { 143 knitr::opts_knit$set(sql.max.print = knit_sql_max_print) 144 }) 145 } 146 147 # set sql.print to use paged tables 148 knit_sql_print <- knitr::opts_knit$get('sql.print'); 149 if (is.null(knit_sql_print)) { 150 knitr::opts_knit$set(sql.print = paged_table_html) 151 exit_actions <<- c(exit_actions, function() { 152 knitr::opts_knit$set(sql.print = knit_sql_print) 153 }) 154 } 155 } 156 157 # pre-processor adds kable-scroll argument to give scrolling treatment for 158 # data frames (which are printed via kable by default) 159 pre_processor <- function(metadata, input_file, runtime, knit_meta, files_dir, 160 output_dir) { 161 args <- c() 162 args <- c(args, pandoc_variable_arg("kable-scroll", "1")) 163 args 164 } 165 166 # post-processor to rename output file if necessary 167 post_processor <- function(metadata, input_file, output_file, clean, verbose) { 168 169 # rename to .nb.html if necessary 170 nb_output_file <- output_file 171 if (!ends_with_bytes(output_file, ".nb.html")) { 172 nb_output_file <- gsub("\\.html$", ".nb.html", output_file) 173 file.rename(output_file, nb_output_file) 174 } 175 176 nb_output_file 177 } 178 179 # these arguments to html_document are fixed so we need to 180 # flag them as invalid for users 181 fixed_args <- c("keep_md", "template", "lib_dir", "dev") 182 forwarded_args <- names(list(...)) 183 for (arg in forwarded_args) { 184 if (arg %in% fixed_args) 185 stop("The ", arg, " option is not valid for the html_notebook format.") 186 } 187 188 # add dependencies 189 extra_dependencies <- append(extra_dependencies, 190 list(html_dependency_pagedtable())) 191 192 # generate actual format 193 base_format <- html_document(toc = toc, 194 toc_depth = toc_depth, 195 toc_float = toc_float, 196 number_sections = number_sections, 197 fig_width = fig_width, 198 fig_height = fig_height, 199 fig_retina = fig_retina, 200 fig_caption = fig_caption, 201 code_folding = code_folding, 202 theme = theme, 203 highlight = highlight, 204 mathjax = mathjax, 205 extra_dependencies = extra_dependencies, 206 css = css, 207 includes = includes, 208 md_extensions = md_extensions, 209 pandoc_args = pandoc_args, 210 self_contained = self_contained, 211 # options forced for notebooks 212 dev = "png", 213 code_download = TRUE, 214 keep_md = FALSE, 215 template = "default", 216 lib_dir = NULL, 217 ...) 218 219 rmarkdown::output_format( 220 knitr = html_notebook_knitr_options(), 221 pandoc = NULL, 222 df_print = paged_table_html_asis, 223 pre_knit = pre_knit, 224 pre_processor = pre_processor, 225 post_processor = post_processor, 226 base_format = base_format, 227 on_exit = on_exit 228 ) 229} 230 231#' Parse an HTML Notebook 232#' 233#' Parse an HTML notebook, retrieving annotation information 234#' related to generated outputs in the document, as well as the 235#' original R Markdown source document. 236#' 237#' See the \href{https://rmarkdown.rstudio.com/r_notebook_format.html}{online 238#' documentation} for additional details on using the \code{html_notebook} 239#' format. 240#' @param path The path to an R Notebook file (with extension \code{.nb.html}). 241#' @export 242parse_html_notebook <- function(path) { 243 244 contents <- read_utf8(path) 245 246 re_comment <- "^\\s*<!--\\s*rnb-([^-]+)-(begin|end)\\s*([^\\s-]+)?\\s*-->\\s*$" 247 re_document <- "^<div id=\"rmd-source-code\">([^<]+)<\\/div>$" 248 249 rmd_contents <- NULL 250 builder <- list_builder() 251 252 for (row in seq_along(contents)) { 253 line <- contents[[row]] 254 255 # extract document contents 256 matches <- gregexpr(re_document, line, perl = TRUE)[[1]] 257 if (!identical(c(matches), -1L)) { 258 start <- c(attr(matches, "capture.start")) 259 end <- start + c(attr(matches, "capture.length")) - 1 260 decoded <- rawToChar(xfun::base64_decode(substring(line, start, end))) 261 rmd_contents <- strsplit(decoded, "\\r?\\n", perl = TRUE)[[1]] 262 next 263 } 264 265 # extract information from comment 266 matches <- gregexpr(re_comment, line, perl = TRUE)[[1]] 267 if (identical(c(matches), -1L)) 268 next 269 270 starts <- c(attr(matches, "capture.start")) 271 ends <- starts + c(attr(matches, "capture.length")) - 1 272 strings <- substring(line, starts, ends) 273 274 n <- length(strings) 275 if (n < 2) 276 stop("invalid rnb comment") 277 278 # decode comment information and update stack 279 data <- list(row = row, 280 label = strings[[1]], 281 state = strings[[2]]) 282 283 # add metadata if available 284 if (n >= 3 && nzchar(strings[[3]])) 285 data[["meta"]] <- base64_decode_object(strings[[3]]) 286 else 287 data["meta"] <- list(NULL) 288 289 # append 290 builder$append(data) 291 } 292 293 annotations <- builder$data() 294 295 # extract header content 296 head_start <- grep("^\\s*<head>\\s*$", contents, perl = TRUE)[[1]] 297 head_end <- grep("^\\s*</head>\\s*$", contents, perl = TRUE)[[1]] 298 299 list(source = contents, 300 rmd = rmd_contents, 301 header = contents[head_start:head_end], 302 annotations = annotations) 303} 304 305html_notebook_annotated_output <- function(output, label, meta = NULL) { 306 before <- if (is.null(meta)) { 307 sprintf("\n<!-- rnb-%s-begin -->\n", label) 308 } else { 309 meta <- base64_encode_object(meta) 310 sprintf("\n<!-- rnb-%s-begin %s -->\n", label, meta) 311 } 312 after <- sprintf("\n<!-- rnb-%s-end -->\n", label) 313 pasted <- paste(before, output, after, sep = "\n") 314 knitr::asis_output(pasted) 315} 316 317html_notebook_annotated_knitr_hook <- function(label, hook, meta = NULL) { 318 force(list(label, hook, meta)) 319 function(x, ...) { 320 321 # call regular hooks and annotate output 322 output <- hook(x, ...) 323 324 # generate output 325 meta <- if (is.function(meta)) meta(x, output, ...) 326 html_notebook_annotated_output(output, label, meta) 327 } 328} 329 330html_notebook_knitr_options <- function() { 331 332 # save original hooks (restore after we've stored requisite 333 # hooks in our output format) 334 saved_hooks <- get_knitr_hook_list() 335 on.exit(set_knitr_hook_list(saved_hooks), add = TRUE) 336 337 # use 'render_markdown()' to get default hooks 338 knitr::render_markdown() 339 340 # store original hooks and annotate in format 341 orig_knit_hooks <- knitr::knit_hooks$get() 342 343 # generic hooks for knitr output 344 hook_names <- c("source", "chunk", "plot", "text", "output", 345 "warning", "error", "message", "error") 346 347 meta_hooks <- list( 348 source = html_notebook_text_hook, 349 output = html_notebook_text_hook, 350 warning = html_notebook_text_hook, 351 message = html_notebook_text_hook, 352 error = html_notebook_text_hook 353 ) 354 355 knit_hooks <- lapply(hook_names, function(hook_name) { 356 html_notebook_annotated_knitr_hook(hook_name, 357 orig_knit_hooks[[hook_name]], 358 meta_hooks[[hook_name]]) 359 }) 360 names(knit_hooks) <- hook_names 361 362 # use a custom 'chunk' hook that ensures that html comments 363 # do not get indented 364 chunk_hook <- knitr::knit_hooks$get("chunk") 365 knit_hooks$chunk <- function(x, options) { 366 367 # update chunk line 368 context <- render_context() 369 context$chunk.index <- context$chunk.index + 1 370 371 # call original hook 372 output <- chunk_hook(x, options) 373 374 # clean up indentation for html 375 if (!is.null(options$indent)) { 376 output <- gsub("\n\\s*<!-- rnb-", "\n<!-- rnb-", output, perl = TRUE) 377 } 378 379 # write annotated output 380 html_notebook_annotated_output(output, "chunk") 381 } 382 383 opts_chunk <- list(render = html_notebook_render_hook, 384 comment = NA) 385 386 # return as knitr options 387 rmarkdown::knitr_options(knit_hooks = knit_hooks, 388 opts_chunk = opts_chunk) 389} 390 391html_notebook_text_hook <- function(input, output, ...) { 392 list(data = input) 393} 394 395html_notebook_render_hook <- function(x, ...) { 396 output <- knitr::knit_print(x, ...) 397 if (inherits(x, "htmlwidget")) 398 return(notebook_render_html_widget(output)) 399 output 400} 401 402prepare_evaluate_output <- function(output, ...) { 403 UseMethod("prepare_evaluate_output") 404} 405 406#' @export 407prepare_evaluate_output.htmlwidget <- function(output, ...) { 408 widget <- knitr::knit_print(output) 409 meta <- attr(widget, "knit_meta") 410 asis <- knitr::asis_output(c(widget)) 411 annotated <- html_notebook_annotated_output(asis, "htmlwidget", meta) 412 attr(annotated, "knit_meta") <- meta 413 annotated 414} 415 416#' @export 417prepare_evaluate_output.knit_asis <- function(output, ...) { 418 output 419} 420 421#' @export 422prepare_evaluate_output.list <- function(output, ...) { 423 lapply(output, prepare_evaluate_output) 424} 425 426#' @export 427prepare_evaluate_output.default <- function(output, ...) { 428 output 429} 430 431as_evaluate_output <- function(output, context, ...) { 432 prepared <- prepare_evaluate_output(output) 433 if (!is.list(prepared)) 434 prepared <- list(prepared) 435 prepared 436} 437 438validate_output_source <- function(output_source) { 439 440 # error message to report 441 required_signature <- "function(code, context, ...) {}" 442 prefix <- "'output_source' should be a function with signature" 443 error_msg <- sprintf("%s '%s'", prefix, required_signature) 444 445 # ensure function 446 if (!is.function(output_source)) stop2(error_msg) 447 448 # check formals 449 fmls <- names(formals(output_source)) 450 if (length(fmls) < 3) stop2(error_msg) 451 452 if (!("..." %in% fmls)) stop2(error_msg) 453 454 TRUE 455} 456