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