R/texture-grob.R

In clauswilke/ggtextures: Drawing Textured Rectangles and Bars with grid and ggplot2

#' Draw rectangle filled with a texture image
#'
#' A texture grob is a grid grob that draws a rectangle filled with an image. The image will
#' be tiled if it is not large enough to fill the entire space of the rectangle.
#' @param img The image, in magick format
#' @param x Unit object specifying x position of rectangle
#' @param y Unit object specifying y position of rectangle
#' @param width Unit object specifying the rectangle width
#' @param height Unit object specifying the rectangle height
#' @param just Vector of two numeric values specifying horizontal and vertical
#'   justification of rectangle relative to `x` and `y`.
#' @param img_width Unit object specifying the width of the texture image.
#'   If `"null"` unit is used, then the image width is calculated relative
#'   to the rectangle width.
#' @param img_height Unit object specifying the height of the texture image.
#'   If `"null"` unit is used, then the image height is calculated relative
#'   to the rectangle height.
#' @param nrow Number of image rows. If `NA`, is calculated automatically
#'   from the available space.
#' @param ncol Number of image columns. If `NA`, is calculated automatically
#'   from the available space.
#' @param hjust Horizontal justification of images.
#' @param vjust Vertical justification of images.
#' @param fill Fill color for rectangle.
#' @param color Border color for rectangle.
#' @param lty Line type for border.
#' @param lwd Line width for border.
#' @param clip Should images be clipped to rectangle extent? `"on"` means
#'   yes, `"off"` means no.
#' @param repmax Maximum number of image repetitions. By default set to 500.
#'   This is a safety check against bad parameter settings that might create
#'   hundreds of thousands of images or more.
#' @param interpolate A logical value indicating whether to linearly interpolate the image
#'  (the alternative is to use nearest-neighbour interpolation, which gives a more blocky result).
#' @examples
#' img <- magick::image_read("https://jeroen.github.io/images/Rlogo.png")
#'
#' grid.newpage()
#' tg1 <- texture_grob(
#'   img,
#'   x = unit(.2, "npc"), y = unit(.05, "npc"),
#'   width = unit(.1, "npc"), height = unit(.9, "npc"),
#'   img_width = unit(.5, "in"), ncol = 1
#' )
#' tg2 <- texture_grob(
#'   img,
#'   x = unit(.5, "npc"), y = unit(.05, "npc"),
#'   width = unit(.3, "npc"), height = unit(.6, "npc"),
#'   img_width = unit(.5, "in"), ncol = 1
#' )
#'
#' grid.draw(tg1)
#' grid.draw(tg2)
#' @export
texture_grob <- function(img,
                         x = unit(0.5, "npc"), y = unit(0.5, "npc"),
                         width = unit(1, "npc"), height = unit(1, "npc"),
                         just = c(0, 0),
                         img_width = unit(1, "null"), img_height = NA,
                         nrow = NA, ncol = NA, hjust = 0.5, vjust = 0,
                         fill = "#E8E8E8", color = "#000000", lty = 1,
                         lwd = 1, clip = "on", repmax = 500, interpolate = TRUE) {
  if (is.null(img)) {
    stop("Cannot create texture grob without valid image.", call. = FALSE)
  }

  # we use NA to indicate missing values, not NULL
  img_width <- img_width %||% NA
  img_height <- img_height %||% NA
  nrow <- nrow %||% NA
  ncol <- ncol %||% NA

  if (is.na(img_width) && is.na(img_height)) {
    stop("Must specify at least one of `img_width` and `img_height`.", call. = FALSE)
  }

  vp <- viewport(x, y, width, height, just = just, clip = clip)

  # image aspect ratio
  asp <- get_asp(img)

  # prebuilding the image grob speeds things up for drawing
  img_grob <- rasterGrob(img, interpolate = interpolate)

  # the actual content is generated by the makeContent() function
  g <- gTree(
    img_grob = img_grob, img_width = img_width, img_height = img_height,
    asp = asp, nrow = nrow, ncol = ncol, hjust = hjust, vjust = vjust,
    fill = fill, color = color, lty = lty, lwd = lwd, repmax = repmax,
    vp = vp, cl = "texture_grob"
  )
}

#' @rdname texture_grob
#' @usage NULL
#' @export
makeContent.texture_grob <- function(x) {
  grob_width_in <- convertWidth(unit(1, "npc"), "in", valueOnly = TRUE)
  grob_height_in <- convertHeight(unit(1, "npc"), "in", valueOnly = TRUE)
  grob_asp <- grob_height_in / grob_width_in
  asp <- x$asp
  img_grob <- x$img_grob

  if (is.na(x$img_width)) {
    # image width not specified
    if (is_null_unit(x$img_height)) {
      img_height_in <- grob_height_in * as.numeric(x$img_height)
    } else {
      img_height_in <- convertHeight(x$img_height, "in", valueOnly = TRUE)
    }
    img_width_in <- img_height_in / asp
  } else if (is.na(x$img_height)) {
    # image height not specified
    if (is_null_unit(x$img_width)) {
      img_width_in <- grob_width_in * as.numeric(x$img_width)
    } else {
      img_width_in <- convertHeight(x$img_width, "in", valueOnly = TRUE)
    }
    img_height_in <- img_width_in * asp
  } else {
    # both image width and image height specified
    if (is_null_unit(x$img_height)) {
      img_height_in <- grob_height_in * as.numeric(x$img_height)
    } else {
      img_height_in <- convertHeight(x$img_height, "in", valueOnly = TRUE)
    }
    if (is_null_unit(x$img_width)) {
      img_width_in <- grob_width_in * as.numeric(x$img_width)
    } else {
      img_width_in <- convertHeight(x$img_width, "in", valueOnly = TRUE)
    }
    # when both width and height are specified we need to adjust the
    # aspect ratio accordingly
    asp <- img_height_in / img_width_in
    img_grob <- editGrob(img_grob, width = unit(img_width_in, "in"), height = unit(img_height_in, "in"))
  }

  ncol <- x$ncol
  if (is.na(ncol)) {
    ncol <- ceiling(grob_width_in / img_width_in) # number of image columns we need
  }
  nrow <- x$nrow
  if (is.na(nrow)) {
    nrow <- ceiling(grob_height_in / img_height_in) # number of image rows we need
  }

  bg <- rectGrob(gp = gpar(fill = x$fill, col = NA))
  fg <- rectGrob(gp = gpar(fill = NA, col = x$color, lty = x$lty, lwd = x$lwd))

  if (nrow*ncol > x$repmax) {
    warning("Number of tiling images exceeds maximum allowed. Verify your settings or increase `repmax`.", call. = FALSE)
    children <- list(
      textGrob("Too many\nimage tiles.\nCheck settings.")
    )
  } else {
    children <- pmap(
      expand.grid(row = 1:nrow, col = 1:ncol),
      function(row, col) {
        vp <- viewport(
          x = unit((col - 1 - (ncol - 1)*x$hjust)*img_width_in + x$hjust*grob_width_in, "in"),
          y = unit((row - 1 - (nrow - 1)*x$vjust)*img_height_in + x$vjust*grob_height_in, "in"),
          width = unit(img_width_in, "in"), height = unit(img_height_in, "in"),
          just = c(x$hjust, x$vjust),
          name = "null"
        )
        rg <- img_grob
        rg$vp <- vp
        # need to change name, otherwise grid doesn't draw :-(
        rg$name <- paste0("child.", row, ".", col)
        rg
      }
    )
  }

  # add background to children
  children <- c(list(bg), children, list(fg))

  # convert to gList and set
  children <- do.call(gList, children)
  setChildren(x, children)
}

# calculate aspect ratio of a magick image
get_asp <- function(img) {
  info <- magick::image_info(img)
  info$height / info$width
}