Allow lib_dir not to be a descendant of the base directory for documents derived from html_document_base

.Rbuildignore

@@ -7,6 +7,8 @@
 ^tests/testthat/site/_site/
 ^tests/testthat/site/lib/
 ^tests/testthat/site/.*_files/
+^tests/testthat/html-uptree-lib_dir/.*\.html$
+^tests/testthat/html-uptree-lib_dir/.*\.gitkeep$
 ^tests/manual/
 ^\.github$
 ^pkgdown$

DESCRIPTION

@@ -47,7 +47,8 @@ Authors@R: c(
     person(, "Drifty", role = "cph", comment = "Ionicons"),
     person("Aidan", "Lister", role = c("ctb", "cph"), comment = "jQuery StickyTabs"),
     person("Benct Philip", "Jonsson", role = c("ctb", "cph"), comment = "pagebreak Lua filter"),
-    person("Albert", "Krewinkel", role = c("ctb", "cph"), comment = "pagebreak Lua filter")
+    person("Albert", "Krewinkel", role = c("ctb", "cph"), comment = "pagebreak Lua filter"),
+    person("Jonathan", "Gilligan", role = "ctb", email = "[email protected]", comment = c(ORCID = "0000-0003-1375-6686"))
   )
 Maintainer: Yihui Xie <[email protected]>
 Description: Convert R Markdown documents into a variety of formats.
@@ -89,5 +90,5 @@ VignetteBuilder: knitr
 Config/Needs/website: rstudio/quillt, pkgdown
 Config/testthat/edition: 3
 Encoding: UTF-8
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 SystemRequirements: pandoc (>= 1.14) - http://pandoc.org

NEWS.md

@@ -1,6 +1,14 @@
 rmarkdown 2.29
 ================================================================================
 
+- `html_document` output allows `lib_dir` to point to a parent of the output 
+  directory if the `allow_uptree_lib_dir` parameter is set to `TRUE`. This used
+  to throw an error, "The path <file> does not appear to be a descendant of 
+  <dir>". This makes it possible to have a directory structure for HTML output
+  where there is a shared master library with css, javascript, etc. and separate 
+  child directories with RMarkdown files. #146 and #1859.
+  (thanks, @jonathan-g, #2199)
+
 - `find_external_resources()` now correctly detects knitr child document provided with option like `child = c("child.Rmd")` (thanks, @rempsyc, #2574).
 
 - `knit_params_ask()` uses a `select` input for parameters which allow multiple selected values. Previously, a `radio` input was incorrectly used when the parameter had a small number of choices.

R/html_dependencies.R

@@ -311,16 +311,114 @@ html_reference_path <- function(path, lib_dir, output_dir) {
     relative_to(output_dir, path)
 }
 
+copy_if_changed <- function(from, to, recursive = FALSE,
+                            overwrite = FALSE, copy.mode = FALSE) {
+  isdir = dir.exists(from)
+  if (isdir) {
+    if (! dir.exists(to)) {
+      dir.create(to, recursive = TRUE)
+    }
+    if (recursive) {
+      from2 = list.files(from, recursive = FALSE, include.dirs = TRUE,
+                        all.files = TRUE, no.. = TRUE)
+      mapply(copy_if_changed, from = file.path(from, from2),
+             to = file.path(to, from2),
+             MoreArgs = list(recursive = recursive, overwrite = overwrite,
+                             copy.mode = copy.mode))
+    }
+  } else {
+    digests <- tools::md5sum(c(from, to))
+    if (!isTRUE(digests[1] == digests[2])) {
+      file.copy(from, to, overwrite = TRUE, copy.mode = FALSE)
+    }
+  }
+}
+
+# This is an almost exact copy of htmltools::copyDependencyToDir, except that
+# it only copies files if necessary.
+#
+# Sometimes, a process (e.g., web server) will be accessing an HTML dependency
+# file when RMarkdown tries to overwrite it, and R throws an error reporting
+# insufficient privilege to delete or overwrite the file or directory.
+#
+# This function reduces that by only copying if the file has changed.
+#
+copy_html_dependency <- function(dependency, outputDir, mustWork = TRUE) {
+  dir <- dependency$src$file
+  if (is.null(dir)) {
+    if (mustWork) {
+      stop("Dependency ", dependency$name, " ",
+           dependency$version, " is not disk-based")
+    }
+    else {
+      return(dependency)
+    }
+  }
+  if (!is.null(dependency$package))
+    dir <- system.file(dir, package = dependency$package)
+  if (length(outputDir) != 1 || outputDir %in% c("",
+                                                 "/"))
+    stop("outputDir must be of length 1 and cannot be \"\" or \"/\"")
+  target_dir <- if (getOption("htmltools.dir.version",
+                              TRUE)) {
+    paste(dependency$name, dependency$version, sep = "-")
+  }
+  else dependency$name
+  target_dir <- file.path(outputDir, target_dir)
+  if (same_path(dir, target_dir))
+    return(dependency)
+  if (!dir_exists(outputDir))
+    dir.create(outputDir)
+
+  # Unlike htmltools::copyDependencyToDir(),
+  # we do not delete the target directory,  but we
+  # do create it if necessary.
+  if (! dir_exists(target_dir)) dir.create(target_dir)
+  files <- if (dependency$all_files)
+    list.files(dir)
+  else {
+    unlist(dependency[c("script", "stylesheet",
+                        "attachment")])
+  }
+  srcfiles <- file.path(dir, files)
+  if (any(!file.exists(srcfiles))) {
+    stop(sprintf("Can't copy dependency files that don't exist: '%s'",
+                 paste(srcfiles, collapse = "', '")))
+  }
+  destfiles <- file.path(target_dir, files)
+  isdir <- file.info(srcfiles)$isdir
+  destfiles <- ifelse(isdir, dirname(destfiles), destfiles)
+  mapply(copy_if_changed, from = srcfiles, to = destfiles,
+         recursive = isdir,
+         MoreArgs = list(overwrite = TRUE, copy.mode = FALSE))
+  dependency$src$file <- normalizePath(target_dir, "/", TRUE)
+  dependency
+}
+
 # return the html dependencies as an HTML string suitable for inclusion
 # in the head of a document
-html_dependencies_as_string <- function(dependencies, lib_dir, output_dir) {
+html_dependencies_as_string <- function(dependencies, lib_dir, output_dir,
+                                        allow_uptree_lib_dir = FALSE) {
   if (!is.null(lib_dir)) {
-    # using mustWork=FALSE insures non-disk based dependencies are
-    # return untouched, keeping the order of all deps.
-    dependencies <- lapply(dependencies, copyDependencyToDir,
-                           outputDir = lib_dir, mustWork = FALSE)
-    dependencies <- lapply(dependencies, makeDependencyRelative,
-                           basepath = output_dir, mustWork = FALSE)
+    if (allow_uptree_lib_dir && grepl("^\\.\\.", lib_dir)) {
+      abs_lib_dir <- normalizePath(lib_dir, winslash = "/")
+      dependencies <- lapply(dependencies, copy_html_dependency, abs_lib_dir,
+                             mustWork = FALSE)
+      dependencies <- lapply(dependencies, makeDependencyRelative, abs_lib_dir,
+                             mustWork = FALSE)
+      return(renderDependencies(dependencies, "file", encodeFunc = identity,
+                                hrefFilter = function(path) {
+                                  file.path(lib_dir, path)
+                                }))
+    } else {
+      # using mustWork=FALSE insures non-disk based dependencies are
+      # return untouched, keeping the order of all deps.
+      dependencies <- lapply(dependencies, copyDependencyToDir,
+                             outputDir = lib_dir, mustWork = FALSE)
+      dependencies <- lapply(dependencies, makeDependencyRelative,
+                             basepath = output_dir, mustWork = FALSE)
+    }
+
   }
 
   # Dependencies are iterated on as file based dependencies needs to be

R/html_document.R

@@ -141,6 +141,8 @@
 #'  default definition of R Markdown. See the \code{\link{rmarkdown_format}} for
 #'  additional details.
 #' @param pandoc_args Additional command line options to pass to pandoc
+#' @param allow_uptree_lib_dir Allow dependencies to be placed in a directory
+#'   above the current document's location in the directory tree.
 #' @param ... Additional function arguments to pass to the base R Markdown HTML
 #'   output formatter \code{\link{html_document_base}}
 #' @return R Markdown output format to pass to \code{\link{render}}
@@ -356,6 +358,52 @@
 #'  Due to the above restrictions, you might consider using the \code{includes}
 #'  parameter as an alternative to providing a fully custom template.
 #'
+#'@section Directory structure:
+#'
+#'  By default \code{html_document} and related HTML document types put
+#'  dependency files into the main output directory or a subdirectory specified
+#'  by the \code{lib_dir} parameter:
+#'  If \code{lib_dir} is not a direct descendant of the main output directory,
+#'  \code{render()} will throw and error with the message
+#'  "The path <file> does not appear to be a descendant of <dir>".
+#'
+#'  Sometimes it is useful to have a directory tree where the different
+#'  HTML documents are in their own subdirectories and the dependencies are in
+#'  a common directory at the root of the site.
+#'
+#'  \itemize{
+#'  \item
+#'  \code{main_dir/}
+#'  \itemize{
+#'  \item
+#'  \code{lib/}
+#'  \itemize{
+#'  \item dependencies go here
+#'  }
+#'  }
+#'  \item \code{index.Rmd}
+#'  \item
+#'  \code{node-01/}
+#'  \itemize{
+#'  \item \code{index.Rmd}
+#'  }
+#'  \item
+#'  \code{node-02/}
+#'  \itemize{
+#'  \item \code{index.Rmd}
+#'  }
+#'  }
+#'
+#'  One way to achieve this is with the `render_site` command, but knitting
+#'  individual documents in subdirectories (such as with the RStudio "knit"
+#'  button) will result in errors.
+#'
+#'  It is possible to achieve this directory structure by setting the
+#'  `allow_uptree_lib_dir` parameter to `yes` or `true` in the
+#'  `output/html_document` section of the YAML header
+#'  and set `lib_dir` to a relative path, such as `../lib` or `../site_lib`
+#'  in `node-01/index.Rmd` and `node-02/index.Rmd` in the example above.
+#'
 #' @examples
 #' \dontrun{
 #' library(rmarkdown)
@@ -394,6 +442,7 @@ html_document <- function(toc = FALSE,
                           lib_dir = NULL,
                           md_extensions = NULL,
                           pandoc_args = NULL,
+                          allow_uptree_lib_dir = FALSE,
                           ...) {
 
   # self_contained = TRUE already uses --standalone
@@ -671,6 +720,7 @@ html_document <- function(toc = FALSE,
                                      pandoc_args = pandoc_args,
                                      extra_dependencies = extra_dependencies,
                                      css = css,
+                                     allow_uptree_lib_dir = allow_uptree_lib_dir,
                                      ...)
   )
 }

R/html_document_base.R

@@ -8,6 +8,8 @@
 #' @param dependency_resolver A dependency resolver
 #' @param copy_resources Copy resources
 #' @param bootstrap_compatible Bootstrap compatible
+#' @param allow_uptree_lib_dir Allow lib_dir not to be a descendent of the
+#'   output directory.
 #' @param ... Ignored
 #'
 #' @return HTML base output format.
@@ -25,6 +27,7 @@ html_document_base <- function(theme = NULL,
                                extra_dependencies = NULL,
                                css = NULL,
                                bootstrap_compatible = FALSE,
+                               allow_uptree_lib_dir = FALSE,
                                ...) {
 
   # default for dependency_resolver
@@ -141,12 +144,21 @@ html_document_base <- function(theme = NULL,
       # If we can add bootstrap for Shiny, do it
       format_deps <- append(format_deps, bootstrap_dependencies("bootstrap"))
     }
+
+    # Allow the user to override default dependencies by injecting alternate
+    # dependencies with the same name into extra_dependencies.
+    if (length(format_deps) > 0  && length(extra_dependencies) > 0) {
+      names(format_deps) <- lapply(format_deps, function(x) x$name)
+      names(extra_dependencies) <- lapply(extra_dependencies, function(x) x$name)
+      format_deps <- format_deps[setdiff(names(format_deps),
+                                         names(extra_dependencies))]
+    }
     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))
+                                            output_dir, allow_uptree_lib_dir))
 
     preserved_chunks <<- extract_preserve_chunks(input_file)
 

R/html_extras.R

@@ -18,18 +18,20 @@ html_extras_for_document <- function(knit_meta, runtime, dependency_resolver,
 
 # convert html extras to the pandoc args required to include them
 pandoc_html_extras_args <- function(extras, self_contained, lib_dir,
-                                    output_dir) {
+                                    output_dir, allow_uptree_lib_dir) {
 
   args <- c()
 
   # dependencies
   dependencies <- extras$dependencies
   if (length(dependencies) > 0) {
     if (self_contained)
-      file <- as_tmpfile(html_dependencies_as_string(dependencies, NULL, NULL))
+      file <- as_tmpfile(html_dependencies_as_string(dependencies, NULL, NULL,
+                                                     allow_uptree_lib_dir = FALSE))
     else
       file <- as_tmpfile(html_dependencies_as_string(dependencies, lib_dir,
-                                                     output_dir))
+                                                     output_dir,
+                                                     allow_uptree_lib_dir))
     args <- c(args, pandoc_include_args(in_header = file))
   }
 

R/output_format.R

@@ -60,6 +60,8 @@
 #'   each file. The return is the new file scope. Also, the arguments should
 #'   include \code{...} for the future extensions.
 #' @param base_format An optional format to extend.
+#' @param allow_uptree_lib_dir Allow \code{lib_dir} output parameter not to
+#'   be a descendent of the output directory.
 #' @return An R Markdown output format definition that can be passed to
 #'   \code{\link{render}}.
 #' @seealso \link{render}, \link{knitr_options}, \link{pandoc_options}
@@ -81,7 +83,8 @@ output_format <- function(knitr,
                           post_processor = NULL,
                           on_exit = NULL,
                           file_scope = NULL,
-                          base_format = NULL) {
+                          base_format = NULL,
+                          allow_uptree_lib_dir = FALSE) {
 
   format <- list(
     knitr = knitr,
@@ -95,7 +98,8 @@ output_format <- function(knitr,
     intermediates_generator = intermediates_generator,
     post_processor = post_processor,
     file_scope = file_scope,
-    on_exit = on_exit
+    on_exit = on_exit,
+    allow_uptree_lib_dir = allow_uptree_lib_dir
   )
 
   class(format) <- "rmarkdown_output_format"
@@ -191,6 +195,8 @@ merge_output_formats <- function(base,
     pandoc = merge_pandoc_options(base$pandoc, overlay$pandoc),
     keep_md =
       merge_scalar(base$keep_md, overlay$keep_md),
+    allow_uptree_lib_dir =
+      merge_scalar(base$allow_uptree_lib_dir, overlay$allow_uptree_lib_dir),
     clean_supporting =
       merge_scalar(base$clean_supporting, overlay$clean_supporting),
     df_print =
@@ -902,7 +908,14 @@ knit_print.output_format_dependency <- function(x, ...) {
 merge_output_format_dependency <- function(fmt, dep) {
   dep$name <- NULL # remove to be consistent with arguments of output_format
   dep$base_format <- fmt
-  do.call(output_format, dep)
+  fmt2 <- do.call(output_format, dep)
+  cls <- class(fmt2)
+  # Make sure named elements are in the same order, to pass tests.
+  fmt2 <- fmt2[c(intersect(names(fmt), names(fmt2)),
+                 setdiff(names(fmt), names(fmt2)),
+                 setdiff(names(fmt2), names(fmt)))]
+  class(fmt2) <- cls
+  fmt2
 }
 
 merge_output_format_dependencies <- function(fmt, deps) {