Merge pull request #17 from teunbrand/master

General Layer Rasteriser

DESCRIPTION

@@ -1,25 +1,28 @@
-Package: ggrastr
-Type: Package
-Title: Raster Layers for 'ggplot2'
-Version: 0.1.9
-Authors@R: c(person("Viktor", "Petukhov", email = "viktor.s.petukhov@ya.ru", role = c("aut", "cph")), person("Evan", "Biederstedt", email = "evan.biederstedt@gmail.com", role=c("cre", "aut")))
-Description: Provides a set of geoms to rasterize only specific layers of the plot while simultaneously keeping all labels and text in vector format. This allows users to keep plots within the reasonable size limit without loosing vector properties of the scale-sensitive information. 
-License: MIT + file LICENSE
-Encoding: UTF-8
-LazyData: true
-Imports:
-  ggplot2 (>= 2.1.0),
-  Cairo (>= 1.5.9),
-  ggbeeswarm
-Depends:
-  R (>= 3.2.2)
-RoxygenNote: 7.1.1
-Suggests:
-  rmarkdown,
-  knitr
-VignetteBuilder: knitr
-URL: https://github.com/VPetukhov/ggrastr
-BugReports: https://github.com/VPetukhov/ggrastr/issues
-NeedsCompilation: no
-Author: Viktor Petukhov [aut, cph], Evan Biederstedt [cre, aut]
-Maintainer: Evan Biederstedt <evan.biederstedt@gmail.com>
+Package: ggrastr
+Type: Package
+Title: Raster Layers for 'ggplot2'
+Version: 0.1.9
+Authors@R: c(person("Viktor", "Petukhov", email = "viktor.s.petukhov@ya.ru", role = c("aut", "cph")), person("Evan", "Biederstedt", email = "evan.biederstedt@gmail.com", role=c("cre", "aut")))
+Description: Provides a set of geoms to rasterize only specific layers of the plot while simultaneously keeping all labels and text in vector format. This allows users to keep plots within the reasonable size limit without loosing vector properties of the scale-sensitive information. 
+License: MIT + file LICENSE
+Encoding: UTF-8
+LazyData: true
+Imports:
+    ggplot2 (>= 2.1.0),
+    Cairo (>= 1.5.9),
+    ggbeeswarm,
+    grid,
+    ragg,
+    png
+Depends:
+  R (>= 3.2.2)
+RoxygenNote: 7.1.1
+Suggests:
+    rmarkdown,
+    knitr
+VignetteBuilder: knitr
+URL: https://github.com/VPetukhov/ggrastr
+BugReports: https://github.com/VPetukhov/ggrastr/issues
+NeedsCompilation: no
+Author: Viktor Petukhov [aut, cph], Evan Biederstedt [cre, aut]
+Maintainer: Evan Biederstedt <evan.biederstedt@gmail.com>

NAMESPACE

@@ -1,15 +1,19 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(makeContext,rasteriser)
 export(geom_beeswarm_rast)
 export(geom_boxplot_jitter)
 export(geom_jitter_rast)
 export(geom_point_rast)
 export(geom_quasirandom_rast)
 export(geom_tile_rast)
+export(rasterise)
+export(rasterize)
 export(theme_pdf)
 import(ggbeeswarm)
 import(ggplot2)
 importFrom(grDevices,dev.cur)
 importFrom(grDevices,dev.off)
 importFrom(grDevices,dev.set)
 importFrom(graphics,par)
+importFrom(grid,makeContext)

R/rasterise.R

@@ -0,0 +1,149 @@
+#' Rasterise ggplot layers
+#'
+#' Takes a ggplot layer as input and renders their graphical output as a raster.
+#'
+#' @param layer A \code{Layer} object, typically constructed with a call to a
+#'   \code{geom_*()} or \code{stat_*()} function.
+#' @param dpi An \code{integer} of length one setting the desired resolution in
+#'   dots per inch.
+#' @param dev A \code{character} specifying a device. Can be one of:
+#'   \code{"cairo"}, \code{"ragg"} or \code{"ragg_png"}.
+#'
+#' @return A modified \code{Layer} object.
+#' @export
+#'
+#' @examples
+#' require(ggplot2)
+#' # `rasterise()` is used to wrap layers
+#' ggplot(pressure, aes(temperature, pressure)) +
+#'   rasterise(geom_line())
+#'
+#' # The `dpi` argument controls resolution
+#' ggplot(faithful, aes(eruptions, waiting)) +
+#'   rasterise(geom_point(), dpi = 5)
+#'
+#' # The `dev` argument offers a few options for devices
+#' require(ragg)
+#' ggplot(diamonds, aes(carat, depth, z = price)) +
+#'   rasterise(stat_summary_hex(), dev = "ragg")
+rasterise <- function(layer, dpi = NULL, dev = "cairo") {
+  dev <- match.arg(dev, c("cairo", "ragg", "ragg_png"))
+
+  if (!inherits(layer, "Layer")) {
+    stop("Cannot rasterise an object of class `", class(layer)[1], "`.",
+         call. = FALSE)
+  }
+
+  # Take geom from input layer
+  old_geom <- layer$geom
+  # Reconstruct input layer
+  ggproto(
+    NULL, layer,
+    # Let the new geom inherit from the old geom
+    geom = ggproto(
+      NULL, old_geom,
+      # draw_panel draws like old geom, but appends info to graphical object
+      draw_panel = function(...) {
+        grob <- old_geom$draw_panel(...)
+        class(grob) <- c("rasteriser", class(grob))
+        grob$dpi <- dpi
+        grob$dev <- dev
+        return(grob)
+      }
+    )
+  )
+}
+
+#' @rdname rasterise
+#' @export
+rasterize <- rasterise
+
+#' @export
+#' @noRd
+#' @importFrom grid makeContext
+#' @method makeContext rasteriser
+makeContext.rasteriser <- function(x) {
+  # Grab viewport information
+  vp <- if(is.null(x$vp)) grid::viewport() else x$vp
+  width <- grid::convertWidth(unit(1, "npc"), "inch", valueOnly = TRUE)
+  height <- grid::convertHeight(unit(1, "npc"), "inch", valueOnly = TRUE)
+
+  # Grab grob metadata
+  dpi <- x$dpi
+  if (is.null(dpi)) {
+    # If missing, take current DPI
+    dpi <- grid::convertWidth(unit(1, "inch"), "pt", valueOnly = TRUE)
+  }
+  dev <- x$dev
+
+  # Clean up grob
+  x$dev <- NULL
+  x$dpi <- NULL
+  class(x) <- setdiff(class(x), "rasteriser")
+
+  # Track current device
+  dev_cur <- grDevices::dev.cur()
+  # Reset current device upon function exit
+  on.exit(grDevices::dev.set(dev_cur), add = TRUE)
+
+  # Setup temporary device for capture
+  if (dev == "cairo") {
+    dev_id <- Cairo::Cairo(
+      type = 'raster',
+      width = width, height = height,
+      units = "in", dpi = dpi, bg = NA
+    )[1]
+  } else if (dev == "ragg") {
+    dev_id <- ragg::agg_capture(
+      width = width, height = height,
+      units = "in", res = dpi,
+      background = NA
+    )
+  } else {
+    # Temporarily make a file to write png to
+    file <- tempfile(fileext = ".png")
+    # Destroy temporary file upon function exit
+    on.exit(unlink(file), add = TRUE)
+    ragg::agg_png(
+      file,
+      width = width, height = height,
+      units = "in", res = dpi,
+      background = NA
+    )
+  }
+
+  # Render layer
+  grid::pushViewport(vp)
+  grid::grid.draw(x)
+  grid::popViewport()
+
+  # Capture raster
+  if (dev != "ragg_png") {
+    cap <- grid::grid.cap()
+  }
+  grDevices::dev.off()
+
+  if (dev == "ragg_png") {
+    # Read in the png file
+    cap <- png::readPNG(file, native = FALSE)
+    dim <- dim(cap)
+    cap <- matrix(
+      grDevices::rgb(
+        red   = as.vector(cap[, , 1]),
+        green = as.vector(cap[, , 2]),
+        blue  = as.vector(cap[, , 3]),
+        alpha = as.vector(cap[, , 4])
+      ),
+      dim[1], dim[2]
+    )
+  }
+
+  # Forward raster grob
+  grid::rasterGrob(
+    cap, x = 0.5, y = 0.5,
+    height = unit(height, "inch"),
+    width = unit(width, "inch"),
+    default.units = "npc",
+    just = "center"
+  )
+}

README.md

@@ -28,7 +28,7 @@ devtools::install_github('VPetukhov/ggrastr', build_vignettes = TRUE)
 * `geom_quasirandom_rast`: raster [quasirandom scatterplot](https://github.com/eclarke/ggbeeswarm#geom_quasirandom)
 
 
-For more details, please see the [vignette](https://htmlpreview.github.io/?https://raw.githubusercontent.com/VPetukhov/ggrastr/master/inst/doc/Raster_geoms.html).
+For more details, see the [vignette](https://htmlpreview.github.io/?https://raw.githubusercontent.com/VPetukhov/ggrastr/master/doc/Raster_geoms.html).
 
 
 ## Troubleshooting