R/standalone-affine-settings.r

In affiner: A Finer Way to Render 3D Illustrated Objects in 'grid' Using Affine Transformations

# ---
# repo: trevorld/affiner
# file: standalone-affine-settings.r
# last-updated: 2023-04-25
# license: https://unlicense.org
# imports: grid
# ---
#
# nocov start
#
# You may copy this source into your own R package
# by either using `usethis::use_standalone("trevorld/affiner", "standalone-affine-settings.r")`
# or simply copying this file into your `R` directory and adding `grid` to the `Imports` of
# your `DESCRIPTION` file.

#' Compute `grid` affine transformation feature viewports and transformation functions
#'
#' `affine_settings` computes `grid` group affine transformation feature viewport and transformation
#' function settings given the (x,y) coordinates of the corners of the
#' affine transformed "viewport" one wishes to draw in.
#'
#' @param xy An R object with named elements `x` and `y` representing the (x,y) coordinates
#'           of the affine transformed "viewport" one wishes to draw in.
#'           The (x,y) coordinates of the "viewport" should be in
#'           "upper left", "lower left", "lower right", and "upper right" order
#'           (this ordering should be from the perspective of **before**
#'           the "affine transformation" of the "viewport").
#' @param unit Which [grid::unit()] to assume the `xy` "x" and "y" coordinates are expressed in.
#' @return A named list with the following group affine transformation feature viewport
#'         and functions settings:\describe{
#'   \item{transform}{An affine transformation function to pass to [affineGrob()] or [useGrob()].
#'                    If `getRversion()` is less than `"4.2.0"` will instead return `NULL`.}
#'   \item{vp}{A [grid::viewport()] object to pass to [affineGrob()] or [useGrob()].}
#'   \item{sx}{x-axis sx factor}
#'   \item{flipX}{whether the affine transformed "viewport" is "flipped" horizontally}
#'   \item{x}{x-coordinate for viewport}
#'   \item{y}{y-coordinate for viewport}
#'   \item{width}{Width of viewport}
#'   \item{height}{Height of viewport}
#'   \item{default.units}{Default [grid::unit()] for viewport}
#'   \item{angle}{angle for viewport}
#' }
#' @seealso Intended for use with [affineGrob()] or perhaps [grid::useGrob()].
#'          See <https://www.stat.auckland.ac.nz/~paul/Reports/GraphicsEngine/groups/groups.html>
#'          for more information about the group affine transformation feature.
#' @keywords internal
#' @noRd
affine_settings <- function(xy = data.frame(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1)),
                            unit = getOption("affiner_grid_unit", "inches")) {
    df <- data.frame(x = xy$x, y = xy$y)
    stopifnot(nrow(df) == 4,
              unit %in% c("snpc",
                          "inches", "inch", "in",
                          "cm", "centimeter", "centimetre",
                          "mm", "points", "bigpts"))
    df <- at_label_face_coords(df)
    x <- at_x(df)
    y <- at_y(df)
    flipX <- at_is_flipped(df)
    origin <- at_origin(df, flipX)
    df <- at_translate_to_origin(df, origin)
    angle <- at_get_angle(df, flipX)
    df <- at_rotate(df, angle)
    width <- at_width(df)
    height <- at_height(df)
    sx <- at_shear_sx(df, flipX, height, width)

    vp <- grid::viewport(x = x, y = y, width = width, height = height,
                         default.units = unit, angle = angle)
    if (getRversion() >= "4.2.0") {
        transform <- function(group, ...) {
            grid::viewportTransform(group, ...,
                                    shear = grid::groupShear(sx = sx),
                                    flip = grid::groupFlip(flipX = flipX))
        }
    } else {
        transform <- NULL
    }

    list(transform = transform, vp = vp,
         sx = sx, flipX = flipX,
         x = x, y = y, width = width, height = height, default.units = unit,
         angle = angle)
}

# given (x,y) coordinates of four points in (affine transformed) rectangle
# label points before and after transformation by position in rectangle
at_label_face_coords <- function(df ) {
    df$before <- c("upper_left", "lower_left", "lower_right", "upper_right")
    df$after <- ""
    i_left <- order(df$x, -df$y) # leftmost points with tie-brakes by y

    # "lower-left" will be the lowest of the two left-most vertices
    if (df[i_left[1], "y"] < df[i_left[2], "y"]) {
        i_ll <- i_left[1]
    } else {
        i_ll <- i_left[2]
    }
    df[i_ll, "after"] <- "lower_left"
    df[shift_idx(i_ll, 2), "after"] <- "upper_right"
    # translate lower-left to origin and rotate so lower-left and upper-right on x-axis
    # then upper-left will be above x-axis and lower-right will be below x-axis
    df0 <- at_translate_to_origin(df, df[i_ll,])
    df0 <- at_rotate(df0, df0[shift_idx(i_ll, 2), "theta"])
    if (df0[shift_idx(i_ll, 1), "y"] > 0) {
        df[shift_idx(i_ll, 1), "after"] <- "upper_left"
        df[shift_idx(i_ll, 3), "after"] <- "lower_right"
    } else {
        df[shift_idx(i_ll, 1), "after"] <- "lower_right"
        df[shift_idx(i_ll, 3), "after"] <- "upper_left"
    }
    df
}

shift_idx <- function(x, i) {
    x2 <- (x + i) %% 4
    if (x2 == 0)
        4
    else
        x2
}

at_is_flipped <- function(df) {
    i_ul <- which(df$after == "upper_left")
    i_next <- ifelse(i_ul < 4L, i_ul + 1L, 1L)
    df[i_next, "after"] != "lower_left"
}

# translate "lower left" (after flipping but before rotation) to (0,0)
# add polar r and theta coordinates
at_translate_to_origin <- function(df, origin) {
    df$x <- df$x - origin$x
    df$y <- df$y - origin$y
    df$theta <- to_t(df$x, df$y)
    df$r <- to_r(df$x, df$y)
    df
}

at_shear_sx <- function(df, flipped, height, width) {
    if (flipped) {
        i_ll <- which(df$before == "lower_right")
        i_ul <- which(df$before == "upper_right")
    } else {
        i_ll <- which(df$before == "lower_left")
        i_ul <- which(df$before == "upper_left")
    }
    (df[i_ul, "x"] - df[i_ll, "x"]) / height
}

at_origin <- function(df, flipped = FALSE) {
    if (flipped)
        i_ll <- which(df$before == "lower_right")
    else
        i_ll <- which(df$before == "lower_left")

    df[i_ll, ]
}

at_x <- function(df) {
    mean(df$x)
}

at_y <- function(df) {
    mean(df$y)
}

at_get_angle <- function(df, flipped = FALSE) {
    if (flipped)
        i_lr <- which(df$before == "lower_left")
    else
        i_lr <- which(df$before == "lower_right")
    df[i_lr, "theta"]
}

at_rotate <- function(df, angle) {
    df$theta <- df$theta - angle
    df$x <- to_x(df$theta, df$r)
    df$y <- to_y(df$theta, df$r)
    df
}

at_width <- function(df) {
    x_ll <- df[which(df$before == "lower_left"), "x"]
    x_lr <- df[which(df$before == "lower_right"), "x"]
    abs(x_lr - x_ll)
}

at_height <- function(df) {
    y_ll <- df[which(df$before == "lower_left"), "y"]
    y_ul <- df[which(df$before == "upper_left"), "y"]
    abs(y_ul - y_ll)
}

# Convert between Cartesian and polar coordinates
to_x <- function(t, r) {
    r * cos(pi * t / 180)
}
to_y <- function(t, r) {
    r * sin(pi * t / 180)
}
to_r <- function(x, y) {
    sqrt(x^2 + y^2)
}
to_t <- function(x, y) {
    180 * atan2(y, x) / pi
}

# nocov end