R/phylopic_utils.R

In rphylopic: Get Silhouettes of Organisms from PhyloPic

#' Flip a PhyloPic silhouette along its horizontal and/or vertical axis
#'
#' The picture can be a [Picture][grImport2::Picture-class] or png array object,
#' e.g., from using [get_phylopic()].
#'
#' @param img A [Picture][grImport2::Picture-class] or png array object, e.g.,
#'   from using [get_phylopic()].
#' @param horizontal \code{logical}. Should the silhouette be flipped
#'   horizontally?
#' @param vertical \code{logical}. Should the silhouette be flipped vertically?
#' @return A [Picture][grImport2::Picture-class] or png array object (matching
#'   the type of `img`)
#' @family transformations
#' @export
flip_phylopic <- function(img, horizontal = TRUE, vertical = FALSE) {
  if (!is.logical(horizontal)) stop("`horizontal` must be TRUE or FALSE.")
  if (!is.logical(vertical)) stop("`vertical` must be TRUE or FALSE.")
  UseMethod("flip_phylopic")
}

#' @export
flip_phylopic.Picture <- function(img, horizontal = TRUE, vertical = FALSE) {
  # modified from
  # https://github.com/thomasp85/ggforce/blob/main/R/trans_linear.R
  if (horizontal) {
    mat <- matrix(c(-1, 0, 0,
                    0, 1, 0,
                    0, 0, 1), ncol = 3, byrow = TRUE)
    img <- transform_picture(img, mat)
  }
  if (vertical) {
    mat <- matrix(c(1, 0, 0,
                    0, -1, 0,
                    0, 0, 1), ncol = 3, byrow = TRUE)
    img <- transform_picture(img, mat)
  }
  img
}

#' @export
flip_phylopic.array <- function(img, horizontal = TRUE, vertical = FALSE) {
  if (length(dim(img)) != 3) {
    stop("`img` must be an array with three dimensions.")
  }

  # modified from https://github.com/richfitz/vectoR/blob/master/R/vector.R
  if (horizontal) {
    img <- img[, rev(seq_len(ncol(img))), , drop = FALSE]
  }
  if (vertical) {
    img <- img[rev(seq_len(nrow(img))), , , drop = FALSE]
  }
  img
}

#' Rotate a PhyloPic silhouette
#'
#' The picture can be a [Picture][grImport2::Picture-class] or png array object,
#' e.g., from using [get_phylopic()]. Note that png array objects can only be
#' rotated by multiples of 90 degrees.
#'
#' @param img A [Picture][grImport2::Picture-class] or png array object, e.g.,
#'   from using [get_phylopic()].
#' @param angle \code{numeric}. The number of degrees to rotate the silhouette
#'   clockwise.
#' @return A [Picture][grImport2::Picture-class] or png array object (matching
#'   the type of `img`)
#' @family transformations
#' @export
rotate_phylopic <- function(img, angle = 90) {
  if (!is.numeric(angle)) stop("`angle` must be a number.")
  UseMethod("rotate_phylopic")
}

#' @export
rotate_phylopic.Picture <- function(img, angle = 90) {
  # change to radians
  angle <- angle / 360 * (2 * pi)
  # change to clockwise
  angle <- (2 * pi) - angle
  # create rotation matrix (modified from
  # https://github.com/thomasp85/ggforce/blob/main/R/trans_linear.R)
  mat <- matrix(c(cos(angle), sin(angle), 0,
                  -sin(angle), cos(angle), 0,
                  0, 0, 1), ncol = 3, byrow = TRUE)
  transform_picture(img, mat)
}

#' @export
rotate_phylopic.array <- function(img, angle = 90) {
  if (length(dim(img)) != 3) {
    stop("`img` must be an array with three dimensions.")
  }
  if (angle %% 90 != 0) {
    stop(paste("`angle` must be divisible by 90. Other angles are not yet",
               "implemented for rasterized PhyloPics."))
  }

  # modified from https://stackoverflow.com/a/16497058/4660582
  if (angle > 0) { # clockwise
    rotate <- function(mat) t(mat[rev(seq_len(nrow(mat))), , drop = FALSE])
  } else if (angle < 0) { # counter clockwise
    rotate <- function(mat) {
      mat_t <- t(mat)
      mat_t[rev(seq_len(nrow(mat_t))), , drop = FALSE]
    }
  }
  img_new <- img
  for (i in seq_len(abs(angle) / 90)) {
    img_new <- simplify2array(
      lapply(seq_len(dim(img_new)[3]),
             function(i) rotate(img_new[, , i]))
    )
  }
  img_new
}

#' @importFrom grImport2 applyTransform
transform_picture <- function(img, mat) {
  # transform the img content given the specified transformation matrix
  img@content <- lapply(img@content, function(cont) applyTransform(cont, mat))
  # transform the xscale and yscale with the same matrix
  img@summary <- transform_summary(img@summary, mat)
  img
}

transform_summary <- function(summary, mat) {
  # transform the corners given the specified transformation matrix
  corners <- expand.grid(x = summary@xscale, y = summary@yscale)
  corners_trans <- mat %*% rbind(corners$x, corners$y, z = 1)
  # maintain the directionality of the scales
  rev_x <- summary@xscale[1] > summary@xscale[2]
  rev_y <- summary@yscale[1] > summary@yscale[2]
  # set the new scales
  summary@xscale <- range(corners_trans[1, ])
  if (rev_x) summary@xscale <- rev(summary@xscale)
  summary@yscale <- range(corners_trans[2, ])
  if (rev_y) summary@yscale <- rev(summary@yscale)
  summary
}

#' Recolor a PhyloPic image
#'
#' Function to recolor and change alpha levels of a PhyloPic image.
#'
#' @param img A [Picture][grImport2::Picture-class] or png array object, e.g.,
#'   from using [get_phylopic()].
#' @param alpha \code{numeric}. A value between 0 and 1, specifying the opacity
#'   of the silhouette.
#' @param color \code{character}. Color to make the outline of the silhouette.
#'   If NULL, the outline color is not changed.
#' @param fill \code{character}. Color to make the body of the silhouette. If
#'   NULL, the body color is not changed.
#' @param remove_background \code{logical}. Should any white background be
#'   removed? Only useful if `img` is a [Picture][grImport2::Picture-class]
#'   object. See details.
#'
#' @details Some PhyloPic silhouettes do not have a transparent background.
#'   Consequently, when color is used with vectorized versions of these images,
#'   the entire image--including the background--is recolored. Setting
#'   `remove_background` to `TRUE` (the default) will remove any white parts of
#'   the image (which should only be the background).
#'
#' @return A [Picture][grImport2::Picture-class] or png array object (matching
#'   the type of `img`)
#' @family transformations
#' @importFrom grDevices rgb col2rgb
#' @export
recolor_phylopic <- function(img, alpha = 1, color = NULL, fill = NULL,
                             remove_background = TRUE) {
  if (!is.numeric(alpha) || alpha < 0 || alpha > 1) {
    stop("`alpha` must be a number between 0 and 1.")
  }
  if (!is.character(color) && !is.null(color)) {
    stop("`color` must be a character value.")
  }
  UseMethod("recolor_phylopic")
}

#' @export
recolor_phylopic.array <- function(img, alpha = 1, color = NULL, fill = NULL,
                                   remove_background = TRUE) {
  if (!is.null(color)) {
    message("Outline color does not currently work with png image objects.")
  }
  dims <- dim(img)
  if (length(dim(img)) != 3) {
    stop("`img` must be an array with three dimensions.")
  }

  # convert to RGBA if needed
  if (dims[3] == 1) { # grayscale
    img <- g_to_rgba(img)
  } else if (dims[3] == 2) { # greyscale and alpha
    img <- ga_to_rgba(img)
  } else if (dims[3] == 3) { # RGB
    img <- rgb_to_rgba(img)
  } else if (dims[3] > 4) { # not supported
    stop(paste("`img` must be in G, GA, RGB, or RGBA format.",
               "More than four channels is not supported."))
  }
  dims <- dim(img) # update dimensions
  if (is.null(fill)) {
    new_img <- array(c(img[, , 1:3], img[, , 4] * alpha), dim = dims)
  } else {
    cols <- col2rgb(fill) / 255
    imglen <- length(img[, , 1])
    new_img <- array(c(rep(cols[1, 1], imglen),
                       rep(cols[2, 1], imglen),
                       rep(cols[3, 1], imglen),
                       img[, , 4] * alpha), dim = dims)
  }
  return(new_img)
}

ga_to_rgba <- function(img) {
  new_img <- array(0, dim = c(dim(img)[1:2], 4))
  new_img[, , 4] <- img[, , 2]
  new_img
}

g_to_rgba <- function(img) {
  new_img <- array(0, dim = c(dim(img)[1:2], 2))
  new_img[, , 2] <- img
  ga_to_rgba(new_img)
}

rgb_to_rgba <- function(img) {
  new_img <- array(0, dim = c(dim(img)[1:2], 4))
  new_img[, , 1:3] <- img[, , 1:3]
  new_img[, , 4] <- 1
  new_img
}

#' @export
recolor_phylopic.Picture <- function(img, alpha = 1, color = NULL, fill = NULL,
                                     remove_background = TRUE) {
  img <- recolor_content(img, alpha, color, fill, remove_background)
  if (length(img@content) == 0) stop("Invalid 'Picture' object")
  return(img)
}

#' @importFrom methods slotNames
recolor_content <- function(x, alpha, color, fill, remove_background) {
  tmp <- lapply(x@content, function(element) {
    if (is(element, "PicturePath")) {
      # a bit of a hack until PhyloPic fixes these white backgrounds
      if (remove_background && "gp" %in% slotNames(element) &&
          "fill" %in% names(element@gp) &&
          element@gp$fill %in% c("#FFFFFFFF", "#FFFFFF")) {
        return(NULL)
      } else {
        element@gp$alpha <- alpha
        if (!is.null(color)) {
          element@gp$col <- color
        }
        if (!is.null(fill)) {
          element@gp$fill <- fill
        }
        return(element)
      }
    } else if (is(element, "PictureGroup")) {
      # need to go another level down
      recolor_content(element, alpha, color, fill, remove_background)
    }
  })
  x@content <- Filter(function(element) !is.null(element), tmp)
  return(x)
}

#' Preview a PhyloPic silhouette
#'
#' Preview a raster or vector representation of a PhyloPic silhouette. This will
#' plot the silhouette on a new page in your default plotting device.
#' @rdname plot_phylopic
#' @aliases plot_phylopic
#' @param x A [Picture][grImport2::Picture-class] or png array object, e.g.,
#'   from using [get_phylopic()].
#' @param ... Other arguments passed on to [grImport2::grid.picture()] or
#'   [grid::grid.raster()].
#' @importFrom grid grid.newpage
#' @importFrom grImport2 grid.picture
#' @export
plot.Picture <- function(x, ...) {
  grid.newpage()
  grid.picture(x, ...)
}

#' @rdname plot_phylopic
#' @importFrom grid grid.newpage grid.raster
#' @export
plot.phylopic <- function(x, ...) {
  grid.newpage()
  grid.raster(x, ...)
}

#' @rdname get_phylopic
#' @param x A [Picture][grImport2::Picture-class] or png array object, e.g.,
#'   from using [get_phylopic()].
#' @param ... Ignored
#' @export
print.Picture <- function(x, ...) {
  dims <- c(abs(diff(x@summary@xscale)), abs(diff(x@summary@yscale)))
  cat(paste0("PhyloPic silhouette object (vector format)",
             "\nDimensions: ", dims[1], " pixels wide and ",
             dims[2], " pixels tall",
             "\nuuid: ", attr(x, "uuid"),
             "\nURL: ", attr(x, "url")))
  invisible(x)
}

# runs print() when you just type the object name (S4-specific)
setMethod(f = "show",
          signature = "Picture",
          definition = function(object) {
            print(object)
          })

#' @rdname get_phylopic
#' @export
print.phylopic <- function(x, ...) {
  dims <- dim(x)
  cat(paste0("PhyloPic silhouette object (raster format)",
             "\nDimensions: ", dims[2], " pixels wide and ",
             dims[1], " pixels tall",
             "\nuuid: ", attr(x, "uuid"),
             "\nURL: ", attr(x, "url")))
  invisible(x)
}