Nothing
#' 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
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.