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