From 6d106650e530d48ec876475066dc817b441be12f Mon Sep 17 00:00:00 2001
From: Roy Storey <kiwiroy@users.noreply.github.com>
Date: Wed, 31 May 2017 13:21:13 +1200
Subject: [PATCH] add data-background to as preference to #195 and support self
 contained url() in style attributes

---
 R/base64.R                                  |   6 +-
 inst/rmd/ioslides/ioslides_presentation.lua |  65 +++++++++-
 tests/testthat/test-ioslides.R              | 124 ++++++++++++++++----
 3 files changed, 168 insertions(+), 27 deletions(-)

diff --git a/R/base64.R b/R/base64.R
index 75b0cb5e43..38c096efd9 100644
--- a/R/base64.R
+++ b/R/base64.R
@@ -117,10 +117,14 @@ process_html_res <- function(html, reg, processor) {
 }
 
 process_images <- function(html, processor) {
-  process_html_res(
+  html <- process_html_res(
     html,
     "<\\s*[Ii][Mm][Gg]\\s+[Ss][Rr][Cc]\\s*=\\s*[\"']([^\"']+)[\"']",
     processor)
+  process_html_res(
+      html,
+      "<[^>]*style=\"[^\"]*url\\(([^\\)]+)\\)",
+      processor)
 }
 
 base64_encode_images <- function(html, encoder) {
diff --git a/inst/rmd/ioslides/ioslides_presentation.lua b/inst/rmd/ioslides/ioslides_presentation.lua
index a1679918d7..92831b30b4 100644
--- a/inst/rmd/ioslides/ioslides_presentation.lua
+++ b/inst/rmd/ioslides/ioslides_presentation.lua
@@ -41,6 +41,39 @@ local function attributes(attr)
   return table.concat(attr_table)
 end
 
+-- Helper function to split a string on spaces
+-- returns a table
+local function split(str)
+  local words = {}
+  for word in str:gmatch("%S+") do table.insert(words, word) end
+  return words
+end
+
+-- Helper function to remove duplicates
+-- returns a table http://stackoverflow.com/a/20067270
+local function uniq(t)
+  local seen = {}
+  local res = {}
+  for _,v in ipairs(t) do
+    if (not seen[v]) then
+      res[#res+1] = v
+      seen[v] = true
+    end
+  end
+  return res
+end
+
+-- Helper function to filter a list
+-- returns a table
+local function grep(f, l)
+  local res = {}
+  for _,v in ipairs(l) do
+    if (f(v)) then
+      res[#res+1] = v
+    end
+  end
+  return res
+end
 
 -- Blocksep is used to separate block elements.
 function Blocksep()
@@ -209,6 +242,8 @@ function Header(lev, s, attr)
   -- detect level 1 header and convert it to a segue slide
   local slide_class = ""
   local hgroup_class = ""
+  local slide_style = ""
+
   -- make all headers < slide_level as segue slides
   if lev < slide_level then
   	-- create a segue slide but add lev class for possible customization
@@ -217,6 +252,29 @@ function Header(lev, s, attr)
     lev = 2
   end
 
+  -- support for slide specific image backgrounds
+  -- alternative is this css
+  -- slide > slide [data-slide-num="7"] {
+  --   background-image: url("figures/xx.jpg");
+  -- }
+  if attr["data-background"] then
+    -- dark is incompatible with fill and let us uniquify nobackground
+    local slide = split(slide_class .. " fill nobackground")
+    slide = grep(function (v)
+      if v:match("^dark$") then return false else return true end
+    end, slide)
+    slide_class = table.concat(uniq(slide), " ")
+    if attr["data-background"]:match("^#") then
+      slide_style = 'background-color: ' .. attr["data-background"] .. ';'
+    else
+      -- assume url
+      slide_style = 'background-image: url(' .. attr["data-background"] .. ');'
+      slide_style = slide_style .. ' background-size: 100% 100%;'
+    end
+    -- remove noise attributes for article
+    attr["data-background"] = nil
+  end
+
   -- extract optional subtitle
   local subtitle = ""
   if lev == 2 then
@@ -264,8 +322,12 @@ function Header(lev, s, attr)
       end
     end
 
+    if string.len(slide_style) > 0 then
+      slide_style = ' style="' .. slide_style .. '"'
+    end
+
     -- return the beginning of the slide
-    return preface .. "<slide class='" .. slide_class .. "'>" ..
+    return preface .. "<slide class=\"" .. slide_class .. "\"" .. slide_style .. ">" ..
            "<hgroup" .. hgroup_class .. ">" .. header ..  "</hgroup>" ..
            "<article " .. attributes(attr) .. ">"
   else
@@ -449,4 +511,3 @@ meta.__index =
     return function() return "" end
   end
 setmetatable(_G, meta)
-
diff --git a/tests/testthat/test-ioslides.R b/tests/testthat/test-ioslides.R
index 7004e33b4f..767a215a91 100644
--- a/tests/testthat/test-ioslides.R
+++ b/tests/testthat/test-ioslides.R
@@ -15,35 +15,60 @@ context("ioslides")
 
 }
 
+mock_markdown <- function(mdtext = NULL,  outputdir = NULL, ... ) {
+  # create input file
+  mdfile <- tempfile(pattern = "mock_XXXXX",
+                     tmpdir = outputdir,
+                     fileext = ".Rmd")
+  cat(mdtext, file = mdfile, sep = "\n", append = FALSE)
+
+  # output file name
+  outfile <- basename(
+    tempfile(pattern = "mock_XXXXX",
+             tmpdir = outputdir,
+             fileext = ".html"
+    )
+  )
+  # convert
+  output <- capture.output(
+    render(mdfile,
+           output_dir = outputdir,
+           output_file = outfile,
+           ioslides_presentation(...)
+    )
+  )
+
+  # read in output
+  html_file <- readLines(file.path(outputdir, outfile))
+
+  # return structure for testing properties of
+  invisible(structure(
+    list(
+      output = output,
+      html_file = html_file
+      ),
+    class = "mocked")
+    )
+}
+
 test_ioslides_presentation <- function() {
 
   skip_on_cran()
 
-  outputdir <-  tempfile()
+  outputdir <- tempfile()
   dir.create(outputdir)
   on.exit(unlink(outputdir), add = TRUE)
 
   # Generate mock md file
   mdtext <- .generate_markdown_for_test()
-  mdfile <- file.path(outputdir, "mock.Rmd")
-  cat(mdtext, file = mdfile, sep = "\n")
-
-  # test conversion
-  outfile <- "mock_default.html"
-  rout2 <- capture.output(
-    render(mdfile,
-           output_dir = outputdir,
-           output_file = outfile,
-           ioslides_presentation()
-    )
-  )
+  mock2 <- mock_markdown(mdtext = mdtext, outputdir = outputdir)
 
   # test argument passing to pandoc
-  expect_true(any(grepl("--slide-level 2", paste(rout2), fixed = TRUE)))
+  expect_true(any(grepl("--slide-level 2", paste(mock2$output), fixed = TRUE)))
 
   # test status of headers in resulting file
   # Header3 should not be a slide header
-  html_file <- readLines(file.path(outputdir, outfile))
+  html_file <- mock2$html_file
   header_lines <- c(
     any(grepl("<h2>Header1</h2>", html_file, fixed = TRUE)),
     any(grepl("<h2>Header2</h2>", html_file, fixed = TRUE)),
@@ -66,22 +91,16 @@ test_ioslides_presentation <- function() {
   )
   expect_false(any(header_classes))
 
-
+  mock3 <- mock_markdown(mdtext = mdtext, outputdir = outputdir, slide_level = 3)
   # Place the header 3 as title slide
-  rout3 <- capture.output(
-    render(mdfile,
-           output_dir = outputdir,
-           output_file = outfile,
-           ioslides_presentation(slide_level = 3)
-    )
-  )
+  rout3 <- mock3$output
 
   # test argument passing to pandoc
   expect_true(any(grepl("--slide-level 3", paste(rout3), fixed = TRUE)))
 
   # test status of headers in resulting file
   # Header3 should be a slide header
-  html_file <- readLines(file.path(outputdir, outfile))
+  html_file <- mock3$html_file
   header_lines <- c(
     any(grepl("<h2>Header1</h2>", html_file, fixed = TRUE)),
     any(grepl("<h2>Header2</h2>", html_file, fixed = TRUE)),
@@ -107,3 +126,60 @@ test_ioslides_presentation <- function() {
 }
 
 test_that("test_ioslides_presentation", test_ioslides_presentation())
+
+test_ioslides_presentation_css <- function() {
+
+  skip_on_cran()
+
+  outputdir <- tempfile()
+  dir.create(outputdir)
+  on.exit(unlink(outputdir), add = TRUE)
+
+  # Generate mock md file for data-background
+  mdtext <- c("# Slide One\n",
+              "## Slide Two {data-background=#CCC}\n",
+              "## Slide Three {data-background=img/test.png}\n",
+              "# Slide Four {data-background=#ABCDEF}\n"
+              )
+  mock <- mock_markdown(mdtext = mdtext, outputdir = outputdir, self_contained = FALSE)
+  html = mock$html_file
+
+  slide_lines <-
+    c(any(grepl('<slide[^>]*class="[^"]*\\bsegue\\b[^"]*".*<h2>Slide One</h2>', html, perl = TRUE))
+    ## separated to be order agnostic
+    , any(grepl('<slide[^>]*class="[^"]*\\bnobackground\\b[^"]*".*<h2>Slide Two</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*class="[^"]*\\bfill\\b[^"]*".*<h2>Slide Two</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*style="background-color: #CCC;".*<h2>Slide Two</h2>', html, perl = TRUE))
+
+    ## separated to be order agnostic - within values of attributes also (hence [^"]*)
+    , any(grepl('<slide[^>]*class="[^"]*\\bnobackground\\b[^"]*".*<h2>Slide Two</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*class="[^"]*\\bfill\\b[^"]*".*<h2>Slide Two</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*style="[^"]*background-image: url\\(img/test.png\\);[^"]*".*<h2>Slide Three</h2>', html))
+    , any(grepl('<slide[^>]*style="[^"]*background-size: 100% 100%;[^"]*".*<h2>Slide Three</h2>', html))
+
+    ## separated to be order agnostic
+    , any(grepl('<slide[^>]*class="[^"]*\\bsegue\\b[^"]*".*<h2>Slide Four</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*class="[^"]*\\bnobackground\\b[^"]*".*<h2>Slide Four</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*class="[^"]*\\bfill\\b[^"]*".*<h2>Slide Four</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*class="[^"]*\\blevel1\\b[^"]*".*<h2>Slide Four</h2>', html, perl = TRUE))
+    , any(grepl('<slide[^>]*style="background-color: #ABCDEF;".*<h2>Slide Four</h2>', html, perl = TRUE))
+
+  )
+  expect_true(all(slide_lines), info = "slide lines - style attribute")
+
+  # Generate mock md file for data-background
+  plot <- file.path(getwd(), 'resources', 'tinyplot.png')
+  mdtext <- c(paste0("## BG Slide {data-background=", plot, "}\n"))
+  mock <- mock_markdown(mdtext = mdtext, outputdir = outputdir, self_contained = TRUE)
+  html = mock$html_file
+
+  slide_lines <-
+    c(any(grepl('<slide[^>]*style="[^"]*background-image: url\\(data:image/png;base64,[^\\)]*);[^"]*".*<h2>BG Slide</h2>', html))
+      ## still separate
+    , any(grepl('<slide[^>]*style="[^"]*background-size: 100% 100%;[^"]*".*<h2>BG Slide</h2>', html))
+    )
+  expect_true(all(slide_lines), info = "slide lines - self contained image")
+}
+
+
+test_that("ioslides presentation is styled", test_ioslides_presentation_css())