R/generate_svg.R

In ThierryO/qrcode: Generate QRcodes with R

#' Generate the QR code as an svg file
#'
#' Create the QR code using [qr_code()] and save it as an svg file.
#' @param qrcode a `qr_code` object as generated by `qr_code`.
#' @param filename Where to store the QR code as svg file.
#'   Silently overwrites existing files.
#'   Tries to create the path, when it doesn't exist.
#' @param size width of the svg file in pixels.
#' Defaults to `300`.
#' @param foreground Stroke and fill colour for the foreground.
#'   Use a valid [CSS colour](https://www.w3schools.com/colors/).
#'   Defaults to `"black"`.
#' @param background Fill colour for the background.
#'   Use a valid [CSS colour](https://www.w3schools.com/colors/).
#'   Defaults to `"white"`.
#' @param show Open the file after creating it.
#'   Defaults to `TRUE` on [interactive()] sessions, otherwise `FALSE`.
#' @param ... Currently ignored.
#' @return invisible `NULL`
#' @examples
#' code <- qr_code("HELLO WORLD")
#' generate_svg(
#'   qrcode = code, filename = tempfile(fileext = ".svg"), show = FALSE
#' )
#' @rdname generate_svg
#' @export
#' @importFrom assertthat assert_that
#' @importFrom utils browseURL
#' @author Thierry Onkelinx
#' @family qr
generate_svg <- function(
  qrcode, filename, size = 300, foreground = "black", background = "white",
  show = interactive(), ...
) {
  UseMethod("generate_svg")
}

#' @rdname generate_svg
#' @export
generate_svg.default <- function(
    qrcode, filename, size = 300, foreground = "black", background = "white",
    show = interactive(), ...
) {
  generate_svg.qr_code(
    qrcode = qrcode, filename = filename, size = size, foreground = foreground,
    background = background, show = show, ...
  )
}

#' @rdname generate_svg
#' @export
generate_svg.qr_code <- function(
  qrcode, filename, size = 300, foreground = "black", background = "white",
  show = interactive(), ...
) {
  assert_that(inherits(qrcode, "qr_code"))
  heading <- c(
    "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>",
    sprintf(
      paste(
        "<svg xmlns=\"http://www.w3.org/2000/svg\"",
        "xmlns:xlink=\"http://www.w3.org/1999/xlink\"",
        "height=\"%1$i\" width=\"%1$i\">"
      ),
      size
    ),
    sprintf("  <g id=\"qrcode:%s\">", escape_svg(attr(qrcode, "string"))),
    sprintf(
      paste(
        "    <rect x=\"0\" y=\"0\" width=\"%1$ipx\" height=\"%1$ipx\"",
        "style=\"fill:%2$s;\"/>"
      ),
      size, background
    )
  )
  footing <- c("  </g>", "</svg>")
  pixel <- size / ncol(qrcode)
  top_left <- (which(qrcode, arr.ind = TRUE) - 1) * pixel
  svg_data <- sprintf(
    paste(
      "    <rect x=\"%.2f\" y=\"%.2f\" width=\"%3$0.2f\" height=\"%3$0.2f\"",
      "stroke=\"%4$s\" stroke-width=\"0.2\" stroke-linecap=\"butt\"",
      "fill=\"%4$s\"/>"
    ),
    top_left[, 2], top_left[, 1], pixel, foreground
  )
  dir.create(dirname(filename), showWarnings = FALSE, recursive = TRUE)
  writeLines(c(heading, svg_data, footing), filename)
  if (show) {
    browseURL(filename) # nocov
  }
  return(invisible(NULL))
}

#' @rdname generate_svg
#' @param fontsize The size of the font in pixels.
#' @export
generate_svg.qr_wifi <- function(
    qrcode, filename, size = 300, foreground = "black", background = "white",
    show = interactive(), ..., fontsize = 15
) {
  assert_that(inherits(qrcode, "qr_wifi"))
  svg_header <- c(
    "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>",
    sprintf(
      paste(
        "<svg xmlns=\"http://www.w3.org/2000/svg\"",
        "xmlns:xlink=\"http://www.w3.org/1999/xlink\"",
        "height=\"%i\" width=\"%i\">"
      ),
      size + 5 * fontsize, size
    ),
    sprintf(
      paste(
        "    <rect x=\"0\" y=\"0\" height=\"%ipx\" width=\"%ipx\"",
        "style=\"fill:%s;\"/>"
      ),
      size + 5 * fontsize, size, background
    )
  )
  generate_svg.qr_code(
    qrcode = qrcode, filename = filename, size = size, show = FALSE,
    foreground = foreground, background = background
  )
  svg_qrcode <- readLines(filename)
  svg_qrcode <- tail(head(svg_qrcode, -1), -2)
  svg_message <- c(
    "<style>",
    sprintf("  .light { font: italic %ipx sans-serif; }", fontsize),
    "</style>",
    sprintf(
      "<text x=\"%i\" y=\"%i\" class=\"light\">Network SSID: %s</text>",
      floor(0.1 * size), floor(size + 1.5 * fontsize), attr(qrcode, "ssid")
    ),
    sprintf(
      "<text x=\"%i\" y=\"%i\" class=\"light\">Encryption: %s</text>",
      floor(0.1 * size), floor(size + 3 * fontsize), attr(qrcode, "encryption")
    ),
    sprintf(
      "<text x=\"%i\" y=\"%i\" class=\"light\">Password: %s</text>",
      floor(0.1 * size), floor(size + 4.5 * fontsize), attr(qrcode, "key")
    )
  )
  writeLines(c(svg_header, svg_qrcode, svg_message, "</svg>"), filename)
  if (show) {
    browseURL(filename) # nocov
  }
  return(invisible(NULL))
}

#' @rdname generate_svg
#' @export
generate_svg.qr_logo <- function(
    qrcode, filename, size = 300, foreground = "black", background = "white",
    show = interactive(), ...
) {
  assert_that(inherits(qrcode, "qr_logo"))
  class(qrcode) <- class(qrcode)[class(qrcode) != "qr_logo"]
  generate_svg(
    qrcode = qrcode, filename = filename, size = size, foreground = foreground,
    background = background, show = FALSE, ...
  )
  svg_content <- readLines(filename)
  requireNamespace("knitr", quietly = TRUE)
  uri <- knitr::image_uri(attr(attr(qrcode, "logo"), "filename"))

  vertical <- switch(
    attr(qrcode, "logo_position")[2],
    b = ncol(qrcode) - attr(qrcode, "logo_height") - 3,
    c = (ncol(qrcode) - attr(qrcode, "logo_height")) / 2, t = 11
  ) * size / ncol(qrcode)
  horizontal <- switch(
    attr(qrcode, "logo_position")[1], l = 11,
    c = (ncol(qrcode) - attr(qrcode, "logo_width")) / 2,
    r = ncol(qrcode) - 3 - attr(qrcode, "logo_width")
  ) * size / ncol(qrcode)

  paste(
    "  <image href = \"%s\" x = \"%.1f\" y = \"%.1f\"",
    "width = \"%.1f\" height = \"%.1f\" />"
  ) |>
    sprintf(
      uri, horizontal, vertical,
      attr(qrcode, "logo_width") * size / ncol(qrcode),
      attr(qrcode, "logo_height") * size / ncol(qrcode)
    ) -> img
  n_svg <- length(svg_content)
  svg_content[-n_svg] |>
    c(img, svg_content[n_svg]) |>
    writeLines(filename)
  if (show) {
    browseURL(filename) # nocov
  }
  return(invisible(NULL))
}

#' @importFrom assertthat assert_that
escape_svg <- function(x) {
  assert_that(is.character(x))
  gsub("&", "&amp;", x) |>
    gsub(pattern = "'", replacement = "&apos;") |>
    gsub(pattern = "\"", replacement = "&qout;") |>
    gsub(pattern = "<", replacement = "&lt;") |>
    gsub(pattern = ">", replacement = "&gt;")
}