Support self-contained images in xaringan slides (close #3)

DESCRIPTION

@@ -22,7 +22,8 @@ Authors@R: c(
     person("Yongfu", "Liao", role = "ctb"),
     person("Malcolm", "Barrett", role = "ctb", comment = c(ORCID = "0000-0003-0299-5825")),
     person("Alessandro", "Gasparini", role = "ctb", comment = c(ORCID = "0000-0002-8319-7624")),
-    person("Yue", "Jiang", role = "ctb", comment = c(ORCID = "0000-0002-9798-5517"))
+    person("Yue", "Jiang", role = "ctb", comment = c(ORCID = "0000-0002-9798-5517")),
+    person("Susan", "Vanderplas", role = "ctb", comment = c(ORCID = "0000-0002-3803-0972"))
     )
 Description: Create HTML5 slides with R Markdown and the JavaScript library
     'remark.js' (<https://remarkjs.com>).

NEWS.md

@@ -4,6 +4,8 @@
 
 - Added the ability to specify an `institute` in the YAML header that is automatically added to the title slide (@paullemmens, #200).
 
+- Added encoding of images specified with markdown/HTML when `self_contained: true`
+
 ## BUG FIXES
 
 - The Infinite Moon Reader (`xaringan::inf_mr()`) didn't take slide properties `layout: true` and `exclude: true` into consideration (thanks, @fmmattioni, #198).

R/render.R

@@ -51,15 +51,16 @@
 #' @note Do not stare at Karl's picture for too long after you turn on the
 #'   \code{yolo} mode. I believe he has Sharingan.
 #'
-#'   Local images that you inserted via the Markdown syntax
-#'   \command{![](path/to/image)} will not be embedded into the HTML file when
-#'   \code{self_contained = TRUE} (only CSS, JavaScript, and R plot files will
-#'   be embedded). You may also download remark.js (via
+#    You may download remark.js (via
 #'   \code{\link{summon_remark}()}) and use a local copy instead of the default
 #'   \code{chakra} argument when \code{self_contained = TRUE}, because it may be
 #'   time-consuming for Pandoc to download remark.js each time you compile your
 #'   slides.
 #'
+#'   \code{self_contained: true} will now encode linked files as long as the file name
+#'   does not contain parentheses, brackets, or <> characters, and as long as
+#'   local files actually exist.
+#'
 #'   Each page has its own countdown timer (when the option \code{countdown} is
 #'   set in \code{nature}), and the timer is (re)initialized whenever you
 #'   navigate to a new page. If you need a global timer, you can use the
@@ -172,6 +173,9 @@ moon_reader = function(
       res = split_yaml_body(input_file)
       write_utf8(res$yaml, input_file)
       res$body = protect_math(res$body)
+      if (self_contained) {
+        res$body = process_self_contained_images(res$body)
+      }
       content = htmlEscape(yolofy(res$body, yolo))
       Encoding(content) = 'UTF-8'
       write_utf8(content, tmp_md)

R/utils.R

@@ -205,3 +205,67 @@ process_slide = function(x) {
   x = protect_math(flatten_chunk(x))
   paste(x, collapse = '\n')
 }
+
+process_self_contained_images = function(x) {
+  # Identify prose lines, don't process further
+  isprose <- xfun::prose_index(x)
+  notprose <- setdiff(1:length(x), isprose)
+  final <- x
+
+  # This is the full regular expression.
+  # \\1 captures the whole tag,
+  # \\2 captures the file link/url
+  # image_regex <- "((?:(?:!\\[.*?\\]\\()|(?:<img .*?src=[\'\"])|(?:background-image: url\\())(.*?)(?:(?:\\))|(?:[\'\"].*?/(?:img)?>)|(?:\\))))"
+
+  # Here it is broken down into reasonable bits and then reassembled
+  open_options <- c("!\\[.*?\\]\\(", "<img .*?src ?= ?[\'\"]", "background-image: url\\(", "background-image: ")
+  close_options <- c("\\)", "[\'\"].*?/(?:img)?>", "\\)", "\\b$")
+  all_open <- paste0("(?:", paste0("(?:", open_options, ")", collapse = "|"), ")")
+  all_close <- paste0("(?:", paste0("(?:", close_options, ")", collapse = "|"), ")")
+  image_regex <- paste0("(", all_open, "(.*?)", all_close, ")")
+
+  # This part captures situations where the image specification is enclosed in backticks.
+  backtick_regex <- paste0("`[^`]*", image_regex, "[^`]*`")
+
+  images <- which(grepl(image_regex, x))
+  not_images <- which(grepl(backtick_regex, x))
+
+  # Remove any backtick-images and notprose lines from the set of identified images
+  images <- setdiff(images, not_images)
+  images <- setdiff(images, notprose)
+
+  if (length(images) > 0) {
+    # Get a list of file paths or URLs to encode
+    encode_tag <- regmatches(x[images], gregexpr(image_regex, x[images]))
+    encode_list <- unique(gsub(image_regex, "\\2", unlist(encode_tag)))
+    encode_file <- function(y) {
+      if (grepl("^(https|www|http)", y)) {
+        ext <- regmatches(y, regexpr("\\.\\w{1,}$", y))
+        tf <- tempfile(fileext = ext)
+        download.file(y, tf, mode = "wb", quiet = T)
+      } else {
+        tf <- y
+      }
+      if (file.exists(tf)) {
+        knitr::image_uri(tf)
+      } else {
+        y
+      }
+    }
+    encoded_list <- sapply(encode_list, encode_file)
+    encoded_list_worked <- encode_list != encoded_list
+    if (sum(!encoded_list_worked) > 0) {
+      warning(sprintf("URI encoding failed for %s images", sum(!encoded_list_worked)))
+    }
+
+    tmp <- x[images]
+
+    # Replace only those pieces where the encoding actually worked
+    for(i in which(encoded_list_worked)) {
+      regmatches(tmp, gregexpr(encode_list[i], tmp, fixed = T)) <- encoded_list[i]
+    }
+
+    final[images] <- tmp
+  }
+  final
+}

tests/testit/test-utils.R

@@ -36,3 +36,22 @@ assert(
   # A space is added in following (can't overwrite first space when 2nd char is *)
   highlight_code(" * paste('a') #<<") %==% "* * paste('a')"
 )
+
+test_uri = "data:image/gif;base64,R0lGODdhAgACAIAAAAAAAP///ywAAAAAAgACAAACAoRRADs="
+assert(
+  "process_self_contained_images handles image specifications correctly",
+  process_self_contained_images("background-image: url(https://www.htmlgoodies.com/images/1x1.gif)") %==%
+    paste0("background-image: url(", test_uri, ")"),
+  process_self_contained_images("background-image: ../1x1.gif") %==%
+    paste0("background-image: ", test_uri),
+  process_self_contained_images("testing, testing <img src='https://www.htmlgoodies.com/images/1x1.gif'/>") %==%
+    paste0("testing, testing <img src='", test_uri, "'/>"),
+  process_self_contained_images("testing, testing <img src='https://www.htmlgoodies.com/images/1x1.gif'></img>") %==%
+    paste0("testing, testing <img src='", test_uri, "'></img>"),
+  process_self_contained_images("testing, testing `<img src='https://www.htmlgoodies.com/images/1x1.gif'/>`") %==%
+    "testing, testing `<img src='https://www.htmlgoodies.com/images/1x1.gif'/>`",
+  process_self_contained_images("testing, testing !()[https://www.htmlgoodies.com/images/1x1.gif]") %==%
+    paste0("testing, testing !()[https://www.htmlgoodies.com/images/1x1.gif]"),
+  process_self_contained_images("testing, testing `!()[https://www.htmlgoodies.com/images/1x1.gif]`") %==%
+    "testing, testing `!()[https://www.htmlgoodies.com/images/1x1.gif]`"
+)