R/chronochrt_geom_imagelabels.R

In chronochrt: Creating Chronological Charts

#' Add image labels to plot
#'
#' Plot images in a ggplot2 object. Supported file types are: \code{.png},
#' \code{.jpg}, \code{.tif}, \code{.bmp.}, \code{.svg} (see
#' \code{\link[magick]{image_read}} for further details).
#'
#' The images are provided by their paths (local files or URLs) via the
#' aesthetic \code{image_path}. Rows with invalid file paths are silently
#' dropped, invalid URLs will throw an error.
#'
#' The absolute size in cm of the images can be specified via the aesthetics
#' \code{height} and \code{width}. If only one is specified, the image is scaled
#' under preservation of its aspect ratio. If both are given, the image might
#' appear distorted. See examples for further details.
#'
#' @inheritParams ggplot2::layer
#' @param ... Other arguments passed on to \code{\link[ggplot2]{layer}}. These are often aesthetics, used to set an aesthetic to a fixed value, like \code{height = 1}.
#'
#' @section Aesthetics: \code{geom_ChronochRtImage()} understands the following
#'   aesthetics (required aesthetics are in bold): \itemize{ \item
#'   \strong{\code{image_path}} \item \strong{\code{x}} \item \strong{\code{y}}
#'   \item \code{group} \item \code{height} \item \code{width} } See Details
#'   for how these aesthetics work.
#'
#' @return Layer of a ggplot2 object.
#'
#' @author
#' This geom is a modified version of the \code{geom_custom()} from \href{https://github.com/baptiste}{Baptiste Auguié}'s \href{https://cran.r-project.org/package=egg}{egg package}.
#'
#' @export
#'
#' @examples
#'
#' library(ggplot2)
#'
#' # Create example data
#' data <- data.frame(x = c(2, 4), y = c(2, 4),
#'                    image_path = "https://www.r-project.org/logo/Rlogo.png",
#'                    height = c(1,2), width = c(3,0.5))
#'
#' q <- ggplot(data) + lims(x = c(0, 6), y = c(0, 6))
#'
#' # Without size specifications
#' q + geom_chronochRtImage(aes(image_path = image_path, x = x, y = y))
#'
#' # Scale images to individual heights/widths by specifying one of them:
#' q + geom_chronochRtImage(aes(image_path = image_path, x = x, y = y, height = height))
#'
#' # Scale images to uniform height/width (i.e. independent of input data):
#' q + geom_chronochRtImage(aes(image_path = image_path, x = x, y = y, height = 1))
#'
#' # Specifying height and width might result in distorted images:
#' q + geom_chronochRtImage(aes(image_path = image_path, x = x, y = y, height = height, width = width))

geom_chronochRtImage <- function(mapping = NULL, data = NULL, inherit.aes = TRUE, ...) {
   ggplot2::layer(
      geom = GeomChronochRtImage,
      mapping = mapping,
      data = data,
      stat = "identity",
      position = "identity",
      show.legend = FALSE,
      inherit.aes = inherit.aes,
      params = list(...)
   )
  }

GeomChronochRtImage <- ggplot2::ggproto("GeomChronochRtImage", ggplot2:::Geom,

   handle_na = function(self, data, params) {
     data
   },
   setup_data = function(self, data, params) {
     data <- ggplot2:::ggproto_parent(ggplot2:::Geom, self)$setup_data(data, params)
     data
   },
   draw_panel = function(data, panel_scales, coord) {
     coords <- coord$transform(data, panel_scales)

     data <- data[file.exists(data$image_path) | grepl("http", data$image_path, fixed = TRUE), ]

     # Let magick::image_read fail gracefully if source is not available
     image_exist <- function (x) {
       return(tryCatch(magick::image_read(x),
                       error=function(e) {
                         message(conditionMessage(e))
                         NA
                         }
       ))
       }

     data$image <- lapply(data$image_path, function(x) image_exist(x))

     if (any(grepl("height", names(data)))) {data$height <- grid::unit(data$height, "cm")}
     if (any(grepl("width", names(data)))) {data$width <- grid::unit(data$width, "cm")}

     gl <- lapply(seq_along(data$image), function(i) {
       .g <- do.call(grid::rasterGrob, c(list(data$image[[i]]), height = list(data$height[[i]]), width = list(data$width[[i]])))
       grid::editGrob(.g,
                      x = grid::unit(coords$x[i], "native"),
                      y = grid::unit(coords$y[i], "native"))
       }
     )

     do.call(grid::grobTree, gl)
   },
   required_aes = c("image_path", "x", "y"),
   default_aes = ggplot2::aes(height = NULL, width = NULL)
)