R/pattern_square.R

In gridpattern: 'grid' Pattern Grobs

#' Square pattern matrix
#'
#' `pattern_square()` returns an integer matrix indicating where each
#' color (or other graphical element) should be drawn on a rectangular grid
#' for a specified square pattern type and subtype.
#' `names_square` lists the currently supported square `type`s (excluding those in `names_weave`).
#'
#' \describe{
#' \item{"horizontal", "vertical"}{"horizontal" and "vertical" simply cycle through the colors
#'   either horizontally or vertically.
#'   Use `subtype` to indicate the (integer) number of colors (or other graphical elements).
#'   "horizontal" will produce horizontal stripes of color whereas "vertical" will produce vertical stripes.}
#' \item{"diagonal", "diagonal_skew"}{"diagonal" and "diagonal_skew" simply cycle through the colors
#'   both horizontally and vertically.
#'   Use `subtype` to indicate the (integer) number of colors (or other graphical elements).
#'   If two colors are requested this provides the standard two-color checkerboard pattern.
#'   If there are more than three colors than "diagonal" will have colored diagonals
#'   going from top left to bottom right while "diagonal_skew" will have them
#'   going form bottom left to top right.}
#' \item{"square"}{"square" attempts a uniform coloring using "square_tiling" before falling
#'                 falling back on "diagonal".  If `subtype` is `1L`, `2L`, `3L`, or `4L` uses "square_tiling"
#'                 else uses "diagonal".}
#' \item{"square_tiling"}{"square_tiling" supports
#'   uniform coloring for (non-staggered) square tilings.
#'   Use `subtype` to either indicate the (integer) number of colors
#'   or a string with four integers such as `"1231"`
#'   (will fill in a 2x2 matrix by row which will then be tiled).
#'   Supports up to a max of four colors.}
#' \item{any pattern from `names_weave`}{
#'   We simply convert the logical matrix returned by [pattern_weave()] into an
#'   integer matrix by having any `TRUE` set to `1L` and `FALSE` set to `2L`.
#'   Hence the various weave patterns only support (up to) two-color patterns.
#'   See [pattern_weave()] for more details about supported `type` and `subtype`.}
#' }
#'
#' @param type Either "diagonal" (default), "diagonal_skew", "horizontal", "vertical",
#'             or any `type` in `names_weave`.  See Details.
#' @param subtype See Details.  For "diagonal", "diagonal_skew", "horizontal", or "vertical"
#'                an integer of the desired number of colors (or other graphical elements).
#' @param nrow Number of rows (height).
#' @param ncol Number of columns (width).
#' @return A matrix of integer values indicating where the each color
#'         (or other graphical element) should be drawn on a rectangular grid.
#'         Indices `[1,1]` of the matrix corresponds to the bottom-left of the grid
#'         while indices `[1,ncol]` corresponds to the bottom-right of the grid.
#'         This matrix has a "pattern_square" subclass which supports a special `print()` method.
#' @examples
#'  # supported square names
#'  print(names_square)
#'
#'  # (main) diagonal has colors going from top left to bottom right
#'  diagonal <- pattern_square("diagonal", 4L, nrow = 7L, ncol = 9L)
#'  print(diagonal)
#'
#'  # skew diagonal has colors going from bottom left to top right
#'  skew <- pattern_square("diagonal_skew", 4L, nrow = 7L, ncol = 9L)
#'  print(skew)
#'
#'  horizontal <- pattern_square("horizontal", 4L, nrow = 8L, ncol = 8L)
#'  print(horizontal)
#'
#'  vertical <- pattern_square("vertical", 4L, nrow = 8L, ncol = 8L)
#'  print(vertical)
#'
#'  # uniform coloring using 4 colors
#'  color4 <- pattern_square("square_tiling", 4L, nrow = 7L, ncol = 9L)
#'  print(color4)
#'
#'  # uniform coloring using 3 colors
#'  color3 <- pattern_square("square_tiling", 3L, nrow = 7L, ncol = 9L)
#'  print(color3)
#'
#'  # also supports the various 'weave' patterns
#'  zigzag <- pattern_square("twill_zigzag", nrow = 15L, ncol = 9L)
#'  print(zigzag)
#'
#' @seealso [grid.pattern_regular_polygon()] for drawing to a graphics device
#'           polygons in multiple color/size/shape patterns.
#'           [pattern_weave()] for more information on "weave" patterns.
#' @export
pattern_square <- function(type = "diagonal", subtype = NULL, nrow = 5L, ncol = 5L) {
    if (type %in% names_weave) {
        v <- as.integer(!pattern_weave(type, subtype, nrow, ncol)) + 1L
        m <- matrix(v, nrow = nrow, ncol = ncol)
    } else {
        m <- switch(type,
                 diagonal = pattern_diagonal(subtype, nrow, ncol),
                 diagonal_skew = pattern_diagonal(subtype, nrow, ncol, skew = TRUE),
                 horizontal = pattern_horizontal(subtype, nrow, ncol),
                 square = pattern_square_type(subtype, nrow, ncol),
                 square_tiling = pattern_square_tiling(subtype, nrow, ncol),
                 vertical = pattern_vertical(subtype, nrow, ncol),
                 abort(paste("Don't recognize square pattern type", type))
             )
    }
    class(m) <- c("pattern_square", "matrix", "array")
    m
}

#' @rdname pattern_square
#' @export
names_square <- c("diagonal", "diagonal_skew", "horizontal",
                  "square", "square_tiling", "vertical")

pattern_diagonal <- function(subtype = NULL, nrow = 5L, ncol = 5L, skew = FALSE) {
    if (is.null(subtype) || is.na(subtype)) subtype <- 3L
    stopifnot(is_integer(subtype))
    m <- matrix(1L, nrow = nrow, ncol = ncol)
    n <- as.integer(subtype)
    if (n == 1L) return(m)
    s <- seq.int(n)
    for (e in s) {
        step <- ifelse(skew, -(e - 1L), e - 1L)
        v <- rep(cycle_elements(s, step), length.out = ncol)
        for (i in seq(e, nrow, n)) {
            m[i, ] <- v
        }
    }
    m
}

pattern_horizontal <- function(subtype = NULL, nrow = 5L, ncol = 5L) {
    if (is.null(subtype) || is.na(subtype)) subtype <- 3L
    stopifnot(is_integer(subtype))
    n <- as.integer(subtype)
    if (nrow > 2L && n > 1L) {
        v1 <- rev(rep(c(seq.int(n, 2L, -1L), 1L), length.out = nrow %/% 2))
        v2 <- rep(seq.int(n), length.out = (nrow %/% 2) + (nrow %% 2))
        v <- c(v1, v2)
    } else {
        s <- seq.int(n)
        v <- rep(s, length.out = nrow)
    }
    v <- rep.int(v, ncol)
    matrix(v, nrow = nrow, ncol = ncol)
}

pattern_square_type <- function(subtype, nrow, ncol) {
    if (is.null(subtype) || is.na(subtype)) subtype <- 3L
    stopifnot(is_integer(subtype))
    n <- as.integer(subtype)
    if (n <= 4)
        pattern_square_tiling(n, nrow, ncol)
    else
        pattern_diagonal(n, nrow, ncol)
}

pattern_square_tiling <- function(subtype, nrow, ncol) {
    if (is.null(subtype) || is.na(subtype)) subtype <- 3L
    stopifnot(is_integer(subtype))
    if (is.character(subtype)) subtype <- strsplit(subtype, "")[[1]]
    m <- matrix(1L, nrow = nrow, ncol = ncol)
    n <- as.integer(subtype)
    if (all(n == 1L)) return(m)
    if (length(n) == 1L) {
        n <- switch(as.character(subtype),
                    `1` = c(1L, 1L, 1L, 1L),
                    `2` = c(2L, 1L, 1L, 2L),
                    `3` = c(1L, 2L, 3L, 1L),
                    `4` = 1:4,
                    n)
    }
    n <- rep_len(n, 4)
    vt <- rep_len(n[1:2], ncol)
    vb <- rep_len(n[3:4], ncol)
    for (i in seq_len(nrow)) {
        if (i %% 2 == 1)
            m[i, ] <- vb
        else
            m[i, ] <- vt
    }
    m
}

pattern_vertical <- function(subtype = NULL, nrow = 5L, ncol = 5L) {
    if (is.null(subtype) || is.na(subtype)) subtype <- 3L
    stopifnot(is_integer(subtype))
    n <- as.integer(subtype)
    if (ncol > 2L && n > 1L) {
        v1 <- rev(rep(c(seq.int(n, 2L, -1L), 1L), length.out = ncol %/% 2))
        v2 <- rep(seq.int(n), length.out = (ncol %/% 2) + (ncol %% 2))
        v <- c(v1, v2)
    } else {
        s <- seq.int(n)
        v <- rep(s, length.out = ncol)
    }
    v <- rep.int(v, nrow)
    matrix(v, nrow = nrow, ncol = ncol, byrow = TRUE)
}

#' @export
print.pattern_square <- function(x, ...) {
    d <- dim(x)
    x <- matrix(int_to_char(x), nrow = d[1], ncol = d[2])
    cat("/", rep("-", ncol(x)), "\\", "\n")
    for (i in rev(seq_len(nrow(x)))) {
        cat("|", x[i, ], "|", "\n")
    }
    cat("\\", rep("-", ncol(x)), "/", "\n")
    invisible(NULL)
}

is_pattern_square <- function(type) {
    (type %in% names_weave) || (type %in% names_square)
}

int_to_char <- function(x) {
    stopifnot(max(x) < 36L)
    char <- as.character(x)
    indices <- which(x > 9L)
    char[indices] <- LETTERS[x[indices] - 9L]
    char
}