html_document_base.R

#' Base output format for HTML-based output formats
#'
#' Creates an HTML base output format suitable for passing as the
#' \code{base_format} argument of the \code{\link{output_format}} function.
#'
#' @inheritParams html_document
#'
#' @param dependency_resolver A dependency resolver
#' @param copy_resources Copy resources
#' @param extra_dependencies Extra dependencies as a list of the
#'   \code{html_dependency} class objects typically generated by
#'   \code{htmltools::\link{htmlDependency}()}.
#' @param bootstrap_compatible Bootstrap compatible
#' @param ... Ignored
#'
#' @return HTML base output format.
#'
#' @export
html_document_base <- function(theme = NULL,
                               self_contained = TRUE,
                               lib_dir = NULL,
                               mathjax = "default",
                               pandoc_args = NULL,
                               template = "default",
                               dependency_resolver = NULL,
                               copy_resources = FALSE,
                               extra_dependencies = NULL,
                               css = NULL,
                               bootstrap_compatible = FALSE,
                               ...) {

  # default for dependency_resovler
  if (is.null(dependency_resolver))
    dependency_resolver <- html_dependency_resolver

  args <- c()

  # self contained document
  if (self_contained) {
    if (copy_resources)
      stop("Local resource copying is incompatible with self-contained documents.")
    validate_self_contained(mathjax)
    args <- c(args, "--self-contained")
  }

  # custom args
  args <- c(args, pandoc_args)

  preserved_chunks <- character()

  output_dir <- ""

  theme <- resolve_theme(theme)

  # In the bs_theme() case, we set the theme globally so that knitting code may
  # alter it before we ultimately compile it into an HTML dependency.
  old_theme <- NULL
  pre_knit <- function(input, ...) {
    if (is_bs_theme(theme)) {
      # merge css file with bslib mechanism...
      for (f in css) theme <<- bslib::bs_add_rules(theme, xfun::read_utf8(f))
      # ...and don't process CSS files further in Pandoc
      css <<- NULL

      # save old theme
      old_theme <<- bslib::bs_global_set(theme)
    }
  }
  post_knit <- function(metadata, input_file, runtime, ...) {}
  on_exit <- function() {
    # In this case, we know we've altered global state, so restore the old theme
    if (is_bs_theme(theme)) bslib::bs_global_set(old_theme)
  }

  # pre_processor
  pre_processor <- function(metadata, input_file, runtime, knit_meta,
                            files_dir, output_dir) {

    args <- c()

    # use files_dir as lib_dir if not explicitly specified
    if (is.null(lib_dir))
      lib_dir <<- files_dir

    # copy supplied output_dir (for use in post-processor)
    output_dir <<- output_dir

    if (!is.null(theme)) {
      theme_arg <- if (is.list(theme)) "bootstrap" else theme
      args <- c(args, pandoc_variable_arg("theme", theme_arg))
    }

    # Process css files as Pandoc argument if not already been processed by bslib
    for (f in css) {
      if (grepl("\\.s[ac]ss$", f)) {
        if (!xfun::loadable("sass")) {
          stop2("Using `.sass` or `.scss` file in `css` argument requires the sass package.")
        }
        f <- sass::sass(
          sass::sass_file(f),
          # write output file to `lib_dir/sass-{sass:::sass_hash()}{[basename(f)}`
          output = sass_output_template(
            basename = xfun::sans_ext(basename(f)),
            tmpdir = lib_dir
          ),
          options = sass::sass_options(output_style = "compressed")
        )
      }
      # do not normalize web path
      if (!xfun::is_web_path(f)) f <- normalized_relative_to(output_dir, f)
      args <- c(args, "--css", pandoc_path_arg(f, backslash = FALSE))
    }

    # resolve and inject extras, including dependencies specified by the format
    # and dependencies specified by the user (via extra_dependencies)
    format_deps <- list()
    format_deps <- append(format_deps, html_dependency_header_attrs())
    if (!is.null(theme)) {
      format_deps <- append(format_deps, list(html_dependency_jquery()))
      # theme was set globally pre-knit, and it may be modified during knit
      if (is_bs_theme(theme)) {
        theme <- bslib::bs_global_get()
      }
      bootstrap_deps <- if (is_bs_theme(theme) && is_shiny(runtime, metadata[["server"]])) {
        list(shiny_bootstrap_lib(theme))
      } else {
        bootstrap_dependencies(theme)
      }
      format_deps <- append(format_deps, htmltools::resolveDependencies(bootstrap_deps))
    }
    else if (isTRUE(bootstrap_compatible) && is_shiny(runtime, metadata[["server"]])) {
      # If we can add bootstrap for Shiny, do it
      format_deps <- append(format_deps, bootstrap_dependencies("bootstrap"))
    }
    format_deps <- append(format_deps, extra_dependencies)

    extras <- html_extras_for_document(knit_meta, runtime, dependency_resolver,
                                       format_deps)
    args <- c(args, pandoc_html_extras_args(extras, self_contained, lib_dir,
                                            output_dir))

    # mathjax
    args <- c(args, pandoc_mathjax_args(mathjax,
                                        template,
                                        self_contained,
                                        lib_dir,
                                        output_dir))

    preserved_chunks <<- extract_preserve_chunks(input_file)

    args
  }

  intermediates_generator <- function(original_input, intermediates_dir) {
    # copy intermediates; skip web resources if not self contained (pandoc can
    # create references to web resources without the file present)
    copy_render_intermediates(original_input, intermediates_dir, !self_contained)
  }

  post_processor <- function(metadata, input_file, output_file, clean, verbose) {
    # if there are no preserved chunks to restore and no resource to copy then no
    # post-processing is necessary
    if (length(preserved_chunks) == 0 && !isTRUE(copy_resources) && self_contained)
      return(output_file)

    # read the output file
    output_str <- read_utf8(output_file)

    # if we preserved chunks, restore them
    if (length(preserved_chunks) > 0) {
      # Pandoc adds an empty <p></p> around the IDs of preserved chunks, and we
      # need to remove these empty tags, otherwise we may have invalid HTML like
      # <p><div>...</div></p>. For the reason of the second gsub(), see
      # https://github.com/rstudio/rmarkdown/issues/133.
      for (i in names(preserved_chunks)) {
        output_str <- gsub(paste0("<p>", i, "</p>"), i, output_str,
                           fixed = TRUE, useBytes = TRUE)
        output_str <- gsub(paste0(' id="[^"]*?', i, '[^"]*?" '), ' ', output_str,
                           useBytes = TRUE)
      }
      output_str <- restorePreserveChunks(output_str, preserved_chunks)
    }

    if (copy_resources) {
      # The copy_resources flag copies all the resources referenced in the
      # document to its supporting files directory, and rewrites the document to
      # use the copies from that directory.
      output_str <- copy_html_resources(one_string(output_str), lib_dir, output_dir)
    } else if (!self_contained) {
      # if we're not self-contained, find absolute references to the output
      # directory and replace them with relative ones
      image_relative <- function(img_src, src) {
        in_file <- utils::URLdecode(src)
        # do not process paths that are already relative
        if (grepl('^[.][.]', in_file)) return(img_src)
        if (length(in_file) && file.exists(in_file)) {
          img_src <- sub(
            src, utils::URLencode(normalized_relative_to(output_dir, in_file)),
            img_src, fixed = TRUE)
        }
        img_src
      }
      output_str <- process_images(output_str, image_relative)
    }

    write_utf8(output_str, output_file)
    output_file
  }

  if (!is.null(theme)) {
    bs3 <- identical("3", theme_version(theme))
    args <- c(args, pandoc_variable_arg("bs3", bs3))
  }

  output_format(
    knitr = NULL,
    pandoc = pandoc_options(
      to = "html", from = NULL, args = args,
      lua_filters = pkg_file_lua(c("pagebreak.lua", "latex-div.lua"))
    ),
    keep_md = FALSE,
    clean_supporting = FALSE,
    pre_knit = pre_knit,
    post_knit = post_knit,
    on_exit = on_exit,
    pre_processor = pre_processor,
    intermediates_generator = intermediates_generator,
    post_processor = post_processor
  )
}

extract_preserve_chunks <- function(input_file, extract = extractPreserveChunks) {
  input_str <- read_utf8(input_file)
  preserve <- extract(input_str)
  if (!identical(preserve$value, input_str)) write_utf8(preserve$value, input_file)
  preserve$chunks
}


# inspired by sass::output_template but writes to a custom temp dir instead of only tempdir()
# TODO: use the one from sass package when sass 0.3.2 in on CRAN (rstudio/sass#77)
sass_output_template <- function(basename = "rmarkdown", dirname = "sass",
                                 fileext = NULL, tmpdir = tempdir()) {
  function(options = list(), suffix = NULL) {
    fileext <- fileext %||% if (isTRUE(options$output_style %in%
                                       c(2, 3)))
      ".min.css"
    else ".css"
    out_dir <- if (is.null(suffix)) {
      tempfile(tmpdir = tmpdir, pattern = dirname)
    }
    else {
      file.path(tmpdir, paste0(dirname, suffix))
    }
    if (!dir.exists(out_dir)) {
      dir.create(out_dir, recursive = TRUE)
    }
    file.path(out_dir, paste0(basename, fileext))
  }
}