R/trans_linear.R

In ggforce: Accelerating 'ggplot2'

#' Create a custom linear transformation
#'
#' This function lets you compose transformations based on a sequence of linear
#' transformations. If the transformations are parameterised the parameters will
#' become arguments in the transformation function. The transformations are
#' one of `rotate`, `shear`, `stretch`, `translate`, and
#' `reflect`.
#'
#' @param ... A number of transformation functions.
#'
#' @return `linear_trans` creates a trans object. The other functions
#' return a 3x3 transformation matrix.
#'
#' @export
#' @importFrom scales trans_new
#'
#' @examples
#' trans <- linear_trans(rotate(a), shear(1, 0), translate(x1, y1))
#' square <- data.frame(x = c(0, 0, 1, 1), y = c(0, 1, 1, 0))
#' square2 <- trans$transform(square$x, square$y, a = pi / 3, x1 = 4, y1 = 8)
#' square3 <- trans$transform(square$x, square$y, a = pi / 1.5, x1 = 2, y1 = -6)
#' square <- rbind(square, square2, square3)
#' square$group <- rep(1:3, each = 4)
#' ggplot(square, aes(x, y, group = group)) +
#'   geom_polygon(aes(fill = factor(group)), colour = 'black')
linear_trans <- function(...) {
  calls <- as.list(substitute(list2(...)))[-1]
  transformations <- sapply(calls, deparse)
  args <- unlist(lapply(calls, function(call) {
    args <- as.list(call)[-1]
    as.character(args[sapply(args, 'class') == 'name'])
  }))
  args <- unique0(args)
  if (any(c('x', 'y') %in% args)) {
    cli::cli_abort('{.arg x} and {.arg y} are preserved argument names')
  }
  args <- c('x', 'y', args)
  trans_fun <- function() {
    env <- environment()
    trans_mat <- Reduce(function(l, r) r %*% l,
                        lapply(calls, eval, envir = env))
    trans <- trans_mat %*% rbind(x, y, z = 1)
    data_frame0(x = trans[1, ], y = trans[2, ])
  }
  formals(trans_fun) <- structure(rep(list(quote(expr = )), length(args)),
                                  names = args)
  inv_fun <- function() {
    env <- environment()
    trans_mat <- Reduce(function(l, r) r %*% l,
                        lapply(calls, eval, envir = env))
    trans_mat <- solve(trans_mat)
    trans <- trans_mat %*% rbind(x, y, z = 1)
    data_frame0(x = trans[1, ], y = trans[2, ])
  }
  formals(inv_fun) <- structure(rep(list(quote(expr = )), length(args)),
                                names = args)
  trans_new(
    name = paste0('linear: ', paste(transformations, collapse = ', ')),
    transform = trans_fun,
    inverse = inv_fun,
    breaks = extended_breaks(),
    format = format_format()
  )
}

#' @rdname linear_trans
#' @param angle An angle in radians
rotate <- function(angle) {
  matrix(c(cos(angle), -sin(angle), 0, sin(angle), cos(angle), 0, 0, 0, 1),
         ncol = 3)
}
#' @rdname linear_trans
#' @param x the transformation magnitude in the x-direction
#' @param y the transformation magnitude in the x-direction
stretch <- function(x, y) {
  matrix(c(x, 0, 0, 0, y, 0, 0, 0, 1), ncol = 3)
}
#' @rdname linear_trans
shear <- function(x, y) {
  matrix(c(1, y, 0, x, 1, 0, 0, 0, 1), ncol = 3)
}
#' @rdname linear_trans
translate <- function(x, y) {
  matrix(c(1, 0, 0, 0, 1, 0, x, y, 1), ncol = 3)
}
#' @rdname linear_trans
reflect <- function(x, y) {
  l <- x^2 + y^2
  matrix(
    c(
      (x^2 - y^2) / l,
      2 * x * y / l,
      0,
      2 * x * y / l,
      (y^2 - x^2) / l,
      0,
      0,
      0,
      1
    ),
    ncol = 3
  )
}