R/images.R

In marquee: Markdown Parser and Renderer for R Graphics

images_as_grobs <- function(paths, env = caller_env()) {
  is_png <- grepl("\\w\\.png$", paths)
  is_jpeg <- grepl("\\w\\.jpe?g$", paths)
  is_svg <- grepl("\\w\\.svg$", paths)
  lapply(seq_along(paths), function(i) {
    if (!is_png[i] && !is_jpeg[i] && !is_svg[i]) {
      if (grepl("^https?://", paths[i])) {
        temp_loc <- tempfile()
        utils::download.file(paths[i], temp_loc, quiet = TRUE)
        paths[i] <- temp_loc
      }
    }
    if (!is_png[i] && !is_jpeg[i] && !is_svg[i]) {
      is_png[i] <- tryCatch(
        {
          png::readPNG(paths[i])
          TRUE
        },
        error = function(...) FALSE
      )
      if (!is_png[i]) {
        is_jpeg[i] <- tryCatch(
          {
            jpeg::readJPEG(paths[i])
            TRUE
          },
          error = function(...) FALSE
        )
      }
      if (!is_png[i] && !is_jpeg[i]) {
        is_svg[i] <- tryCatch(
          suppressWarnings(grepl("^<svg", readLines(paths[i], n = 1))),
          error = function(...) FALSE
        )
      }
    }
    obj <- NULL
    if (is_png[i]) {
      obj <- try_fetch(
        rasterGrob(png::readPNG(paths[i], native = TRUE)),
        error = function(...) NULL
      )
    } else if (is_jpeg[i]) {
      obj <- try_fetch(
        rasterGrob(jpeg::readJPEG(paths[i], native = TRUE)),
        error = function(...) NULL
      )
    } else if (is_svg[i]) {
      check_installed("rsvg")
      svg <- suppressWarnings(charToRaw(paste0(
        trimws(readLines(paths[i])),
        collapse = "\n"
      )))
      obj <- try_fetch(
        rsvg::rsvg_nativeraster(svg, width = 500),
        error = function(...) NULL
      )
      if (!is.null(obj)) {
        obj <- svg_grob(svg, ncol(obj) / nrow(obj))
      }
    }
    if (is.null(obj) && paths[i] != "") {
      obj <- get0(paths[i], envir = env)
    }
    if (inherits(obj, "patchwork")) {
      check_installed("patchwork")
      obj <- patchwork::patchworkGrob(obj)
    }
    if (inherits(obj, "ggplot")) {
      check_installed("ggplot2")
      obj <- ggplot2::ggplotGrob(obj)
    }
    if (inherits(obj, "gt_tbl")) {
      check_installed("gt")
      obj <- as_gtable$fun(obj)
    }
    if (is.null(obj) || !is.grob(obj)) {
      obj <- missing_grob()
    }
    obj
  })
}

missing_grob <- function() {
  grobTree(
    segmentsGrob(
      x0 = c(0, 0),
      y0 = c(0, 1),
      x1 = c(1, 1),
      y1 = c(1, 0),
      gp = gpar(col = "red", lwd = 2)
    ),
    rectGrob(
      gp = gpar(col = "black", fill = NA, lwd = 4)
    ),
    vp = viewport(
      clip = if (utils::packageVersion("grid") < package_version("4.1.0")) {
        "on"
      } else {
        rectGrob()
      }
    ),
    cl = "missing_grob"
  )
}

svg_grob <- function(
  path,
  asp = NULL,
  x = unit(0.5, "npc"),
  y = unit(0.5, "npc"),
  just = "centre",
  hjust = NULL,
  vjust = NULL,
  default.units = "npc",
  name = NULL,
  gp = gpar(),
  vp = NULL
) {
  gTree(
    path = path,
    asp = asp,
    x = x,
    y = y,
    just = just,
    hjust = hjust,
    vjust = vjust,
    default.units = default.units,
    name = name,
    gp = gp,
    vp = vp,
    cl = "svg_grob"
  )
}

#' @export
makeContent.svg_grob <- function(x) {
  width <- convertWidth(unit(1, "npc"), "inches", TRUE) * 300
  raster <- rsvg::rsvg_nativeraster(x$path, width = width)
  setChildren(x, gList(rasterGrob(raster, width = unit(1, "npc"))))
}