R/agg_dev.R

In ragg: Graphic Devices Based on AGG

#' Draw to a PPM file
#'
#' The PPM (Portable Pixel Map) format defines one of the simplest storage
#' formats available for
#' image data. It is basically a raw 8bit RGB stream with a few bytes of
#' information in the start. It goes without saying, that this file format is
#' horribly inefficient and should only be used if you want to play around with
#' a simple file format, or need a file-based image stream.
#'
#' @param filename The name of the file. Follows the same semantics as the file
#'   naming in [grDevices::png()], meaning that you can provide a [sprintf()]
#'   compliant string format to name multiple plots (such as the default value)
#' @param width,height The dimensions of the device
#' @param units The unit `width` and `height` is measured in, in either pixels
#'   (`'px'`), inches (`'in'`), millimeters (`'mm'`), or centimeter (`'cm'`).
#' @param pointsize The default pointsize of the device in pt. This will in
#'   general not have any effect on grid graphics (including ggplot2) as text
#'   size is always set explicitly there.
#' @param background The background colour of the device
#' @param res The resolution of the device. This setting will govern how device
#'   dimensions given in inches, centimeters, or millimeters will be converted
#'   to pixels. Further, it will be used to scale text sizes and linewidths
#' @param scaling A scaling factor to apply to the rendered line width and text
#'   size. Useful for getting the right dimensions at the resolution that you
#'   need. If e.g. you need to render a plot at 4000x3000 pixels for it to fit
#'   into a layout, but you find that the result appears to small, you can
#'   increase the `scaling` argument to make everything appear bigger at the
#'   same resolution.
#' @param snap_rect Should axis-aligned rectangles drawn with only fill snap to
#'   the pixel grid. This will prevent anti-aliasing artifacts when two
#'   rectangles are touching at their border.
#' @param bg Same as `background` for compatibility with old graphic device APIs
#'
#' @export
#'
#' @examples
#' file <- tempfile(fileext = '.ppm')
#' agg_ppm(file)
#' plot(sin, -pi, 2*pi)
#' dev.off()
#'
agg_ppm <- function(
  filename = 'Rplot%03d.ppm',
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  file <- validate_path(filename)
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  .Call(
    "agg_ppm_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    PACKAGE = 'ragg'
  )
  invisible()
}

#' Draw to a PNG file
#'
#' The PNG (Portable Network Graphic) format is one of the most ubiquitous
#' today, due to its versatiliity
#' and widespread support. It supports transparency as well as both 8 and 16 bit
#' colour. The device uses default compression and filtering and will not use a
#' colour palette as this is less useful for antialiased data. This means that
#' it might be possible to compress the resulting image even more if size is of
#' concern (though the defaults are often very good). In contrast to
#' [grDevices::png()] the date and time will not be written to the file, meaning
#' that similar plot code will produce identical files (a good feature if used
#' with version control). It will, however, write in the dimensions of the image
#' based on the `res` argument.
#'
#' @inheritParams agg_ppm
#' @param bitsize Should the device record colour as 8 or 16bit
#'
#' @export
#'
#' @examples
#' file <- tempfile(fileext = '.png')
#' agg_png(file)
#' plot(sin, -pi, 2*pi)
#' dev.off()
#'
agg_png <- function(
  filename = 'Rplot%03d.png',
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  bitsize = 8,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  file <- validate_path(filename)
  if (!bitsize %in% c(8, 16)) {
    stop('Only 8 and 16 bit is supported', call. = FALSE)
  }
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  .Call(
    "agg_png_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    as.integer(bitsize),
    PACKAGE = 'ragg'
  )
  invisible()
}
#' Draw to a TIFF file
#'
#' The TIFF (Tagged Image File Format) format is a very versatile raster image
#' storage format that supports 8 and 16bit colour mode, true transparency, as
#' well as a range of other features not relevant to drawing from R (e.g.
#' support for different colour spaces). The storage mode of the image data is
#' not fixed and different compression modes are possible, in contrast to PNGs
#' one-approach-fits-all. The default (uncompressed) will result in much larger
#' files than PNG, and in general PNG is a better format for many of the graphic
#' types produced in R. Still, TIFF has its purposes and sometimes this file
#' format is explicetly requested.
#'
#' @section Transparency:
#' TIFF have support for true transparency, meaning that the pixel colour is
#' stored in pre-multiplied form. This is in contrast to pixels being stored in
#' plain format, where the alpha values more function as a mask. The utility of
#' this is not always that important, but it is one of the benefits of TIFF over
#' PNG so it should be noted.
#'
#' @inheritParams agg_png
#' @param compression The compression type to use for the image data. The
#' standard options from the [grDevices::tiff()] function are available under
#' the same name.
#'
#' @note `'jpeg'` compression is only available if ragg is compiled with a
#' version of `libtiff` where jpeg support has been turned on.
#'
#' @export
#'
#' @examples
#' file <- tempfile(fileext = '.tiff')
#' # Use jpeg compression
#' agg_tiff(file, compression = 'lzw+p')
#' plot(sin, -pi, 2*pi)
#' dev.off()
#'
agg_tiff <- function(
  filename = 'Rplot%03d.tiff',
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  compression = 'none',
  bitsize = 8,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  file <- validate_path(filename)
  encoding <- switch(compression, 'lzw+p' = , 'zip+p' = 1L, 0L)
  compression <- switch(
    compression,
    'none' = 0L,
    'rle' = 2L,
    'lzw+p' = ,
    'lzw' = 5L,
    'jpeg' = 7L,
    'zip+p' = ,
    'zip' = 8L
  )
  if (!bitsize %in% c(8, 16)) {
    stop('Only 8 and 16 bit is supported', call. = FALSE)
  }
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  .Call(
    "agg_tiff_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    as.integer(bitsize),
    compression,
    encoding,
    PACKAGE = 'ragg'
  )
  invisible()
}
#' Draw to a JPEG file
#'
#' The JPEG file format is a lossy compressed file format developed in
#' particular for digital photography. The format is not particularly
#' well-suited for line drawings and text of the type normally associated with
#' statistical plots as the compression algorithm creates noticable artefacts.
#' It is, however, great for saving image data, e.g. heightmaps etc. Thus, for
#' standard plots, it would be better to use [agg_png()], but for plots that
#' includes a high degree of raster image rendering this device will result in
#' smaller plots with very little quality degradation.
#'
#' @inheritParams agg_png
#' @param quality An integer between `0` and `100` defining the quality/size
#' tradeoff. Setting this to `100` will result in no compression.
#' @param smoothing A smoothing factor to apply before compression, from `0` (no
#' smoothing) to `100` (full smoothing). Can also by `FALSE` (no smoothing) or
#' `TRUE` (full smoothing).
#' @param method The compression algorithm to use. Either `'slow'`, `'fast'`, or
#' `'float'`. Default is `'slow'` which works best for most cases. `'fast'`
#' should only be used when quality is below `97` as it may result in worse
#' performance at high quality settings. `'float'` is a legacy options that
#' calculate the compression using floating point precission instead of with
#' integers. It offers no quality benefit and is often much slower.
#'
#' @note Smoothing is only applied if ragg has been compiled against a jpeg
#' library that supports smoothing.
#'
#' @export
#'
#' @examples
#' file <- tempfile(fileext = '.jpeg')
#' agg_jpeg(file, quality = 50)
#' plot(sin, -pi, 2*pi)
#' dev.off()
#'
agg_jpeg <- function(
  filename = 'Rplot%03d.jpeg',
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  quality = 75,
  smoothing = FALSE,
  method = 'slow',
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  file <- validate_path(filename)
  quality <- min(100, max(0, quality))
  if (is.logical(smoothing)) smoothing <- if (smoothing) 100 else 0
  smoothing <- min(100, max(0, smoothing))
  method <- match.arg(tolower(method), c('slow', 'fast', 'float'))
  method <- match(method, c('slow', 'fast', 'float')) - 1L
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  .Call(
    "agg_jpeg_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    as.integer(quality),
    as.integer(smoothing),
    method,
    PACKAGE = 'ragg'
  )
  invisible()
}
#' Draw to a PNG file, modifying transparency on the fly
#'
#' The graphic engine in R only supports 8bit colours. This is for the most part
#' fine, as 8bit gives all the fidelity needed for most graphing needs. However,
#' this may become a limitation if you need to plot thousands of very
#' translucent shapes on top of each other. 8bit only afford a minimum of 1/255
#' alpha, which may end up accumulating to fully opaque at some point. This
#' device allows you to create a 16bit device that modifies the alpha level of
#' all incomming colours by a fixed multiplier, thus allowing for much more
#' translucent colours. The device will only modify transparent colour, so if
#' you pass in an opaque colour it will be left unchanged.
#'
#' @inheritParams agg_ppm
#' @param alpha_mod A numeric between 0 and 1 that will be multiplied to the
#' alpha channel of all transparent colours
#'
#' @export
#' @keywords internal
#'
agg_supertransparent <- function(
  filename = 'Rplot%03d.png',
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  alpha_mod = 1,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  file <- validate_path(filename)
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  .Call(
    "agg_supertransparent_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    as.double(alpha_mod),
    PACKAGE = 'ragg'
  )
  invisible()
}

#' Draw to a buffer that can be accessed directly
#'
#' Usually the point of using a graphic device is to create a file or show the
#' graphic on the screen. A few times we need the image data for further
#' processing in R, and instead of writing it to a file and then reading it back
#' into R the `agg_capture()` device lets you get the image data directly from
#' the buffer. In contrast to the other devices this device returns a function,
#' that when called will return the current state of the buffer.
#'
#' @inheritParams agg_ppm
#'
#' @return A function that when called returns the current state of the buffer.
#' The return value of the function depends on the `native` argument. If `FALSE`
#' (default) the return value is a `matrix` of colour values and if `TRUE` the
#' return value is a `nativeRaster` object.
#'
#' @importFrom grDevices dev.list dev.off dev.cur dev.capture dev.set
#' @export
#'
#' @examples
#' cap <- agg_capture()
#' plot(1:10, 1:10)
#'
#' # Get the plot as a matrix
#' raster <- cap()
#'
#' # Get the plot as a nativeRaster
#' raster_n <- cap(native = TRUE)
#'
#' dev.off()
#'
#' # Look at the output
#' plot(as.raster(raster))
#'
agg_capture <- function(
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  name <- paste0('agg_capture_', sample(.Machine$integer.max, 1))
  .Call(
    "agg_capture_c",
    name,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    PACKAGE = 'ragg'
  )
  cap <- function(native = FALSE) {
    current_dev = dev.cur()
    if (names(current_dev)[1] == name) {
      return(dev.capture(native = native))
    }
    all_dev <- dev.list()
    if (!name %in% names(all_dev)) {
      stop('The device (', name, ') is no longer open', call. = FALSE)
    }
    dev.set(all_dev[name])
    on.exit(dev.set(current_dev))
    dev.capture(native = native)
  }
  invisible(cap)
}

#' Capture drawing instructions without rendering
#'
#' While the point of a graphics device is usually to render the graphics, there
#' are a few situations where you are instead interested in only capturing the
#' instructions required to render the graphics. While all graphics devices can
#' be retrofitted for that using [dev.control()], they would still render to
#' their internal buffer even if you are only interested in the recorded
#' instructions, thus adding a performance penalty. `agg_record()` is a device
#' that does no rendering whatsoever, but has recording turned on by default
#' making it a no-overhead solution for plot recording.
#'
#' @inheritParams agg_ppm
#'
#' @export
#'
#' @examples
#' # Capture drawing instructions
#' agg_record()
#' plot(1:10, 1:10)
#' rec <- recordPlot()
#' dev.off()
#'
#' # Replay these on another device
#' file <- tempfile(fileext = '.png')
#' agg_png(file)
#' replayPlot(rec)
#' dev.off()
#'
agg_record <- function(
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  name <- paste0('agg_record_', sample(.Machine$integer.max, 1))
  .Call(
    "agg_record_c",
    name,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    PACKAGE = 'ragg'
  )
  invisible()
}

#' Draw to a WebP file
#'
#' The WebP format is a raster image format that provides improved lossless (and
#' lossy) compression for images on the web. Transparency is supported.
#'
#' @inheritParams agg_png
#' @param lossy Use lossy compression. Default is `FALSE`.
#' @param quality An integer between `0` and `100` defining either the quality
#' (if using lossy compression) or the compression effort (if using lossless).
#'
#' @export
#'
#' @examples
#' file <- tempfile(fileext = '.webp')
#' agg_webp(file)
#' plot(sin, -pi, 2*pi)
#' dev.off()
#'
agg_webp <- function(
  filename = 'Rplot%03d.webp',
  width = 480,
  height = 480,
  units = 'px',
  pointsize = 12,
  background = 'white',
  res = 72,
  scaling = 1,
  snap_rect = TRUE,
  lossy = FALSE,
  quality = 80,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }
  if (max(width, height) > 16383) {
    stop('WebP does not support image width or height larger than 16383 px',
         call. = FALSE)
  }
  if (quality < 0 || quality > 100) {
    stop('quality must be between 0 and 100', call. = FALSE)
  }
  file <- validate_path(filename)
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg
  .Call(
    "agg_webp_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    as.logical(lossy),
    as.integer(quality),
    PACKAGE = 'ragg'
  )
  invisible()
}

#' Draw an animation to a WebP file
#'
#' The WebP format is a raster image format that provides improved lossless (and
#' lossy) compression for images on the web. Transparency is supported.
#'
#' @inheritParams agg_webp
#' @param filename The name of the file. This function does not perform page
#'   number substitution as the other devices since it cannot produce multiple
#'   pages.
#' @param delay      Per-frame delay in milliseconds (single integer)
#' @param loop       Number of loops (0 = infinite)
#'
#' @seealso [agg_webp()] for static WebP images
#'
#' @export
#'
#' @examples
#' \dontrun{
#' file <- tempfile(fileext = '.webp')
#' agg_webp_anim(file, delay = 100, loop = 0)
#' for(i in 1:10) {
#'   plot(sin(1:100 + i/10), type = 'l', ylim = c(-1, 1))
#'   dev.flush()
#' }
#' dev.off()
#' }
agg_webp_anim <- function(
  filename   = 'Ranim.webp',
  width      = 480,
  height     = 480,
  units      = 'px',
  pointsize  = 12,
  background = 'white',
  res        = 72,
  scaling    = 1,
  snap_rect  = TRUE,
  lossy      = FALSE,
  quality    = 80,
  delay      = 100L,
  loop       = 0L,
  bg
) {
  if (
    environmentName(parent.env(parent.frame())) == "knitr" &&
      deparse(sys.call(), nlines = 1, width.cutoff = 500) ==
        'dev(filename = filename, width = dim[1], height = dim[2], ...)'
  ) {
    units <- 'in'
  }

  if (max(width, height) > 16383) {
    stop("WebP does not support image width or height larger than 16383 px",
         call. = FALSE)
  }
  if (quality < 0 || quality > 100) {
    stop('quality must be between 0 and 100', call. = FALSE)
  }
  if (delay < 0) {
    stop('delay must be non-negative', call. = FALSE)
  }
  if (loop < 0) {
    stop('loop count must be non-negative', call. = FALSE)
  }

  file <- validate_path(filename)
  dim <- get_dims(width, height, units, res)
  background <- if (missing(bg)) background else bg

  .Call(
    "agg_webp_anim_c",
    file,
    dim[1],
    dim[2],
    as.numeric(pointsize),
    background,
    as.numeric(res),
    as.numeric(scaling),
    as.logical(snap_rect),
    as.logical(lossy),
    as.integer(quality),
    as.integer(delay),
    as.integer(loop),
    PACKAGE = "ragg"
  )

  invisible()
}