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