R/utils.R

# function to lookup reveal resource
reveal_resources <- function(...) {
  system.file("rmarkdown/templates/revealjs_presentation/resources",
              ...,
              package = "revealjs.ids")
}


revealjs_lib_path <- function(...) {
  pkg <- system.file(package = "revealjs.ids")
  lib_folder <- list.files(pkg, pattern = "reveal.js-")[1]
  system.file(lib_folder, ..., package = "revealjs.ids")
}

revealjs_version <- function() {
  as.numeric_version(gsub(".*reveal\\.js-(.*)$", "\\1", revealjs_lib_path()))
}

# Convert boolean from R to JS boolean
jsbool <- function(value) ifelse(value, "true", "false")

# transfrom reveal option as pandoc variable
process_reveal_option <- function(option, value) {
  if (is.logical(value)) {
    value <- jsbool(value)
  } else if (is.character(value)) {
    # Special handling for some vector options 
    if (
      # chalkboard plugin options
      # e.g: color: [ 'rgba(0,0,255,1)', 'rgba(255,255,255,0.5)' ]
      grepl("chalkboard-(background|draw)", option)
      # e.g autoAnimateStyles: ['opacity','color']
      || grepl("autoAnimateStyles", option)
    ) {
      if (length(value) > 1 || !grepl("^\\[.*\\]$", value)) {
        value <- sprintf("[%s]", paste(paste0("'", value, "'"), collapse = ", "))
      }
    }
    # Add quotes around some config that can be several type
    # like number or percent unit or slideNumber = true or slideNumber = 'c/t'
    if (
      option %in% c("slideNumber") ||
      (option %in% c("width", "height") && grepl("%$", value))) {
      value <- paste0("'", value, "'")
    }
  }
  pandoc_variable_arg(option, value)
}

# Resolve a logo image (yaml entries `partner_logo` / `funder_logo`) to a URL
# usable inside CSS: http(s) and data URLs pass through unchanged, local
# files are inlined as base64 data URIs. Inlining is required: CSS background
# URLs would resolve relative to the theme stylesheet, and document-relative
# files would be left behind when the rendered html is deployed elsewhere.
logo_uri <- function(path) {
  if (grepl("^(https?|data):", path)) {
    return(path)
  }
  if (!file.exists(path)) {
    stop("Logo file not found: ", path, call. = FALSE)
  }
  ext <- tolower(tools::file_ext(path))
  mime <- switch(ext,
    svg = "image/svg+xml", png = "image/png", jpg = , jpeg = "image/jpeg",
    gif = "image/gif", webp = "image/webp",
    stop("Unsupported logo format '", ext, "' (use svg, png, jpg, gif or webp)",
      call. = FALSE
    )
  )
  if (!requireNamespace("base64enc", quietly = TRUE)) {
    stop("Package \"base64enc\" needed to embed local logo files. Please install it.",
      call. = FALSE
    )
  }
  sprintf("data:%s;base64,%s", mime, base64enc::base64encode(path))
}

# qrcode::generate_svg() paints the code -- quiet zone included -- into a
# fixed 300x300 canvas and emits no viewBox, so the svg cannot be resized by
# CSS: given a smaller box it keeps drawing at full size and only its top
# left corner remains visible. Give it a viewBox cropped to the dark modules
# instead. The code then scales to whatever box it is placed in, and its
# quiet zone becomes the surrounding layout's business (on the title slide
# the white plate behind the code supplies it), which keeps the placement
# independent of how many modules the encoded url happens to need.
qr_svg_fit <- function(svg) {
  rects <- regmatches(svg, gregexpr("<rect[^>]*fill=\"black\"[^>]*>", svg))[[1]]
  attr_num <- function(name) {
    suppressWarnings(as.numeric(
      sub(sprintf(".*[ ]%s=\"([0-9.]+)(px)?\".*", name), "\\1", rects)
    ))
  }
  x <- attr_num("x")
  y <- attr_num("y")
  w <- attr_num("width")
  h <- attr_num("height")
  if (!length(rects) || anyNA(c(x, y, w, h))) {
    return(svg)
  }
  left <- min(x)
  top <- min(y)
  side <- max(max(x + w) - left, max(y + h) - top)
  vb <- sprintf(
    'viewBox="%s %s %s %s" width="%s" height="%s"',
    format(left), format(top), format(side), format(side),
    format(side), format(side)
  )
  root <- regmatches(svg, regexpr("<svg[^>]*>", svg))
  fitted <- sub(
    "<svg", paste("<svg", vb),
    gsub("[ ](width|height)=\"[0-9.]+\"", "", root),
    fixed = TRUE
  )
  # the xml prolog would end up as a stray comment once inlined into html
  sub("^<[?]xml[^>]*[?]>", "", sub(root, fitted, svg, fixed = TRUE))
}

#' HTML code for a linked QR code
#'
#' Generates a QR code (inline SVG) linking to the given URL and returns the
#' corresponding HTML code, so a QR code can be placed anywhere in a
#' presentation with inline R code.
#'
#' The `website` YAML entry of [revealjs_presentation()] uses this to
#' place a linked QR code in the top left of the title slide.
#'
#' @param url Target URL for the QR code
#' @param logo Optional path to a logo image to place in the center of the QR
#'   code
#' @param text Optional caption displayed below the QR code (alias:
#'   `caption`)
#' @param caption Alias for `text`
#' @return Character string with HTML code for a linked QR code
#' @export
qrlink <- function(url, logo = NULL, text = NULL, caption = text) {
  if (!requireNamespace("qrcode", quietly = TRUE)) {
    stop("Package \"qrcode\" needed to generate QR codes. Please install it.",
      call. = FALSE
    )
  }
  tmp <- tempfile(fileext = ".svg")
  qrcode <- qrcode::qr_code(url, ecl = if (is.null(logo)) "L" else "H")
  if (!is.null(logo)) {
    qrcode <- qrcode::add_logo(qrcode, logo, ecl = "L")
  }
  qrcode::generate_svg(qrcode, tmp, show = FALSE)

  cap_html <- if (!is.null(caption) && nchar(trimws(caption)) > 0) {
    sprintf('<span class="qrcode-caption">%s</span>', caption)
  } else {
    ""
  }

  svg <- qr_svg_fit(gsub("\r?\n|\r", "", readChar(tmp, 1e7)))
  qr <- sprintf('<a class="qrcode" href="%s">%s</a>', url, svg)
  if (nchar(cap_html) > 0) {
    paste0('<div class="qrcode-container">', qr, cap_html, "</div>")
  } else {
    qr
  }
}