R/pp_cfg.R
In trevorld/piecepackr: Board Game Graphics
Defines functions
impute_suit
impute_rank
as.list.pp_cfg
is_pp_cfg
pp_cfg
Documented in
is_pp_cfg
pp_cfg
#' Configuration list R6 object
#'
#' `pp_cfg()` and `as_pp_cfg()` create piecepack configuration list R6 objects.
#' `is_pp_cfg()` returns `TRUE` if object is a piecepack configuration list R6 object.
#' `as.list()` will convert it into a list.
#'
#' `pp_cfg` R6 class objects serve the following purposes:
#'
#' * Customize the appearance of pieces drawn by `grid.piece()`.
#' * Speed up the drawing of graphics through use of caching.
#' * Allow the setting and querying of information about the board game components
#' that maybe of use to developers:
#'
#' + Number of suits
#' + Number of ranks
#' + Suit colors
#' + Which types of components are included and/or properly supported
#' + What would be a good color to use when adding annotations on top of these components.
#' + Title, Description, Copyright, License, and Credit metadata
#'
#' @section `pp_cfg` R6 Class Method Arguments:\describe{
#' \item{`piece_side`}{A string with piece and side separated by a underscore e.g. "coin_face".}
#' \item{`suit`}{Number of suit (starting from 1).}
#' \item{`rank`}{Number of rank (starting from 1).}
#' \item{`type`}{Which type of grob to return, either `"normal"`, `"picture"`, `"raster"`, or `"transformation"`.}
#' \item{`scale`}{"scale" factor}
#' \item{`alpha`}{"alpha" value}
#' }
#'
#' @section `pp_cfg` R6 Class Methods:\describe{
#' \item{`get_grob()`}{Returns a \code{grid} \dQuote{grob} for drawing the piece.}
#' \item{`get_piece_opt()`}{Returns a list with info useful for drawing the piece.}
#' \item{`get_suit_color()`}{Returns the suit colors.}
#' \item{`get_width()`, `get_height()`, `get_depth()`}{
#' Dimensions (of the bounding cube) of the piece in inches}
#' }
#'
#' @section \code{pp_cfg} R6 Class Fields and Active Bindings:\describe{
#' \item{`annotation_color`}{Suggestion of a good color to annotate with}
#' \item{`cache`}{Cache object which stores intermediate graphical calculations.
#' Default is a memory-cache that does not prune.
#' This can be replaced by another cache that
#' implements the cache API used by the `cachem` package}
#' \item{`cache_grob`}{Whether we should cache (2D) grobs}
#' \item{`cache_grob_with_bleed_fn`}{Whether we should cache the grob with bleed functions}
#' \item{`cache_piece_opt`}{Whether we should cache piece opt information}
#' \item{`cache_op_fn`}{Whether we should cache the oblique projection functions}
#' \item{`cache_obj_fn`}{Whether we should cache any 3D rendering functions}
#' \item{`copyright`}{Design copyright information}
#' \item{`credit`}{Design credits}
#' \item{`description`}{Design description}
#' \item{`fontfamily`}{Main font family}
#' \item{`has_bits`}{Whether we should assume this supports "bit" pieces}
#' \item{`has_boards`}{Whether we should assume this supports "board" pieces}
#' \item{`has_cards`}{Whether we should assume this supports "card" pieces}
#' \item{`has_coins`}{Whether we should assume this supports "coin" pieces}
#' \item{`has_dice`}{Whether we should assume this supports "die" pieces}
#' \item{`has_matchsticks`}{Whether we should assume this supports "matchstick" pieces}
#' \item{`has_pawns`}{Whether we should assume this supports "pawn" pieces}
#' \item{`has_piecepack`}{Binding which simultaneously checks/sets
#' `has_coins`, `has_tiles`, `has_pawns`, `has_dice`}
#' \item{`has_pyramids`}{Whether we should assume this supports "pyramid" pieces}
#' \item{`has_saucers`}{Whether we should assume this supports "saucer" pieces}
#' \item{`has_tiles`}{Whether we should assume this supports "tile" pieces}
#' \item{`spdx_id`}{SPDX Identifier for graphical design license.
#' See \url{https://spdx.org/licenses/} for full list.}
#' \item{`title`}{Design title}
#' }
#'
#' @section Defunct `pp_cfg` R6 Class attributes which have been removed:\describe{
#' \item{`cache_shadow`}{Use `cache_op_fn` instead}
#' \item{`i_unsuit`}{Instead add `1L` to `n_suits`}
#' \item{`get_pictureGrob()`}{Use `get_grob(..., type = "picture")` instead}
#' \item{`get_shadow_fn`}{`get_op_grob()` returns complete oblique projection grob}
#' }
#'
#' @seealso [game_systems()] for functions that return configuration list
#' objects for several game systems.
#' <https://trevorldavis.com/piecepackr/configuration-lists.html> for more details
#' about `piecepackr` configuration lists.
#' @param cfg List of configuration options
#' @examples
#' cfg <- pp_cfg(list(invert_colors=TRUE))
#' as.list(cfg)
#' is_pp_cfg(cfg)
#' as_pp_cfg(list(suit_color="darkred,black,darkgreen,darkblue,grey"))
#' cfg$get_suit_color(suit=3)
#' cfg$annotation_color
#' cfg$has_matchsticks
#' cfg$has_matchsticks <- TRUE
#' cfg$has_matchsticks
#' cfg$get_width("tile_back")
#' cfg$get_height("die_face")
#' cfg$get_depth("coin_face")
#' \donttest{# May take more than 5 seconds on CRAN servers
#' # `pp_cfg()` objects use a cache to speed up repeated drawing
#' pdf(tempfile(fileext = ".pdf"))
#' cfg <- list()
#' system.time(replicate(100, grid.piece("tile_back", 4, 4, cfg)))
#' cfg <- pp_cfg(list())
#' system.time(replicate(100, grid.piece("tile_back", 4, 4, cfg)))
#' invisible(dev.off())
#' }
#'
#' @export
pp_cfg <- function(cfg=list()) {
if (is_pp_cfg(cfg))
cfg
else
Config$new(cfg)
}
#' @rdname pp_cfg
#' @export
is_pp_cfg <- function(cfg) inherits(cfg, "pp_cfg")
#' @rdname pp_cfg
#' @export
as_pp_cfg <- pp_cfg
#' @export
as.list.pp_cfg <- function(x, ...) {
x$as_list()
}
default_lacks_suit <- c("tile_back", "saucer_back", "coin_face", "card_back")
default_lacks_rank <- c("tile_back", "coin_back", "card_back",
"pawn_face", "pawn_back", "belt_face",
"saucer_face", "saucer_back", "suitdie_face")
impute_rank <- function(piece_side, rank, cfg) {
ifelse(piece_side %in% cfg$lacks_rank,
cfg$n_ranks+1L,
ifelse(is.na(rank), 1L, min(rank, cfg$n_ranks+2L)))
}
impute_suit <- function(piece_side, suit, cfg) {
ifelse(piece_side %in% cfg$lacks_suit,
cfg$n_suits+1L,
ifelse(is.na(suit), 1L, min(suit, cfg$n_suits+2L)))
}
Config <- R6Class("pp_cfg",
public = list(
cache = NULL,
has_bits = FALSE,
has_boards = FALSE,
has_cards = FALSE,
has_coins = TRUE,
has_dice = TRUE,
has_matchsticks = FALSE,
has_pawns = TRUE,
has_pyramids = FALSE,
has_saucers = FALSE,
has_tiles = TRUE,
initialize = function(cfg=list()) {
warn_cfg(cfg)
self$cache <- Cache$new()
private$cfg <- cfg
private$cfg$n_suits <- cfg$n_suits %||% (length(get_suit_symbols(cfg=cfg, expand=FALSE)) - 1L)
private$cfg$n_ranks <- cfg$n_ranks %||% length(get_rank_symbols(cfg=cfg, expand=FALSE))
private$cfg$lacks_rank <- cleave2(cfg$lacks_rank %||% default_lacks_rank)
private$cfg$lacks_suit <- cleave2(cfg$lacks_suit %||% default_lacks_suit)
# so different cfg objects can share the same cache (with high probability)
private$prefix <- as.hexmode(sample.int(2147483647L, 1L, useHash=TRUE))
},
get_grob = function(piece_side, suit, rank,
type = c("normal", "picture", "raster", "transformation"),
...) {
type <- match.arg(type)
grob <- switch(type,
normal = private$get_grob_normal(piece_side, suit, rank),
picture = private$get_grob_picture(piece_side, suit, rank),
raster = to_rasterGrob(self$get_raster(piece_side, suit, rank, ...)),
transformation = private$get_grob_transformation(piece_side, suit, rank))
grob
},
get_grob_with_bleed = function(piece_side, suit, rank) {
rank <- impute_rank(piece_side, rank, self)
suit <- impute_suit(piece_side, suit, self)
key <- private$opt_cache_key(piece_side, suit, rank, "grob_with_bleed_fn")
grob_fn <- self$cache$get(key, key_missing())
if (is.key_missing(grob_fn)) {
default_grob_fn <- basicGrobWithBleed
grob_fn <- get_style_element("grob_with_bleed_fn", piece_side, private$cfg,
default_grob_fn, suit, rank)
if (is.character(grob_fn))
grob_fn <- match.fun(grob_fn)
if (self$cache_grob_with_bleed_fn) self$cache$set(key, grob_fn)
}
args <- list(piece_side = piece_side, suit = suit, rank = rank,
cfg = self)
do.call(grob_fn, args)
},
get_piece_opt = function(piece_side, suit=NA, rank=NA) {
if (is.na(rank)) rank <- 1L
if (is.na(suit)) suit <- self$n_suits + 1L
key <- private$opt_cache_key(piece_side, suit, rank, "piece_opt")
opt <- self$cache$get(key, key_missing())
if (is.key_missing(opt)) {
opt <- get_piece_opt_helper(piece_side, suit, rank, private$cfg)
if (self$cache_piece_opt) self$cache$set(key, opt)
}
opt
},
get_suit_color = function(suit=NULL) {
if (is.null(suit)) suit <- seq(self$n_suits)
colors <- character(length(suit))
for (ii in seq(along.with=suit)) {
colors[ii] <- get_suit_color_helper("pawn_face", suit[ii], rank=1, private$cfg)
}
colors
},
get_width = function(piece_side, suit=1, rank=1) {
key <- private$opt_cache_key(piece_side, suit, rank, "width")
width <- self$cache$get(key, key_missing())
if (!is.key_missing(width))
return(width)
if (grepl("die_layout", piece_side)) {
die_width <- self$get_width("die_face")
return(4 * die_width)
}
if (grepl("pyramid_layout", piece_side)) {
pyramid_height <- self$get_height("pyramid_face", rank=rank)
return(pyramid_height)
}
if (piece_side == "preview_layout") {
tile_width <- self$get_width("tile_face")
return(3 * tile_width)
}
piece <- get_piece(piece_side)
if (grepl("_left$|_right$", piece_side) && piece != "pyramid") {
ps <- paste0(piece, "_face")
return(self$get_height(ps, suit=suit, rank=rank))
}
default <- switch(piece,
belt = 0.75 * pi, # so can wrap around 3/4" diameter pawns
bit = 0.75,
board = 8,
card = 2.5,
coin = 0.75,
die = 0.5,
matchstick = MATCHSTICK_WIDTHS[rank],
pawn = 0.5,
pyramid = PYRAMID_WIDTHS[rank],
saucer = 0.75, # better than 7/8" for diagrams of hex games played with coin+pawn
suitdie = 0.5,
tile = 2,
abort(paste("Don't know width of piece", piece)))
width <- get_style_element("width", piece_side, private$cfg, default, suit, rank)
self$cache$set(key, width)
width
},
get_height = function(piece_side, suit=1, rank=1) {
key <- private$opt_cache_key(piece_side, suit, rank, "height")
height <- self$cache$get(key, key_missing())
if (!is.key_missing(height))
return(height)
if (grepl("die_layout", piece_side)) {
die_height <- self$get_height("die_face")
return(3 * die_height)
}
if (grepl("pyramid_layout", piece_side)) {
pyramid_height <- self$get_height("pyramid_face", rank=rank)
pyramid_width <- self$get_width("pyramid_face", rank=rank)
pyramid_diagonal <- sqrt(pyramid_height^2 + (0.5*pyramid_width)^2)
return(2 * pyramid_diagonal)
}
if (grepl("pyramid_top", piece_side)) {
pyramid_width <- self$get_width("pyramid_face", rank=rank)
return(pyramid_width)
}
if (grepl("pawn_layout", piece_side)) {
pawn_height <- self$get_height("pawn_face")
return((2.5 / (7/8)) * pawn_height)
}
if (piece_side == "preview_layout") {
tile_height <- self$get_height("tile_face")
return(3 * tile_height)
}
piece <- get_piece(piece_side)
if (grepl("_top$|_base$|_left$|_right$", piece_side) && piece != "pyramid") {
ps <- paste0(piece, "_face")
return(self$get_depth(ps, suit=suit, rank=rank))
}
width <- self$get_width(piece_side, suit, rank)
if (piece == "matchstick") {
W <- ifelse(rank == 1, 0.5*width, width)
S <- 0.5 * self$get_width("tile_face")
ms_default <- (c(2*W, S-W, sqrt(2)*S-W, 2*S-W, sqrt(5*S^2)-W, 2*sqrt(2)*S-W)[rank])
}
default <- switch(piece,
belt = 0.5,
bit = width,
board = width,
card = 1.4 * width,
coin = width,
die = width,
matchstick = ms_default,
pawn = 0.875,
pyramid = 1.538842 * width,
saucer = width,
suitdie = width,
tile = width,
abort(paste("Don't know height of piece", piece))) #nocov
height <- get_style_element("height", piece_side, private$cfg, default, suit, rank)
self$cache$set(key, height)
height
},
get_depth = function(piece_side, suit=1, rank=1) {
key <- private$opt_cache_key(piece_side, suit, rank, "depth")
depth <- self$cache$get(key, key_missing())
if (!is.key_missing(depth))
return(depth)
width <- self$get_width(piece_side, suit, rank)
if (grepl("pyramid", piece_side)) {
height <- self$get_height("pyramid_face", rank=rank)
if (piece_side == "pyramid_top") {
return(sqrt(height^2 - (0.5*width)^2))
} else {
theta <- 2 * asin(0.5 * width / height)
return(sin(theta) * height)
}
}
piece <- get_piece(piece_side)
if (grepl("_top$|_base$", piece_side)) {
ps <- paste0(piece, "_face")
return(self$get_height(ps, suit=suit, rank=rank))
} else if (grepl("_left$|_right$", piece_side)) {
ps <- paste0(piece, "_face")
return(self$get_width(ps, suit=suit, rank=rank))
}
default <- switch(piece,
bit = 0.25,
board = 0.25,
card = 0.01181102, # 3 mm
coin = 0.125,
die = width,
matchstick = width,
pawn = 0.25,
saucer = 0.125,
suitdie = width,
tile = 0.25,
0)
depth <- get_style_element("depth", piece_side, private$cfg, default, suit, rank)
self$cache$set(key, depth)
depth
},
as_list = function() private$cfg,
print = function() {
for (name in sort(names(private$cfg))) {
if (is.function(private$cfg[[name]])) {
cat(paste0("$", name, " : ", "a function", "\n"))
} else {
cat(paste0("$", name, " : ", paste(private$cfg[[name]], collapse=",")), "\n")
}
}
},
get_op_grob = function(piece_side, suit, rank,
x, y, z, angle, type,
width, height, depth,
op_scale, op_angle) {
key <- private$opt_cache_key(piece_side, suit, rank, "op_grob")
grob_fn <- self$cache$get(key, key_missing())
if (is.key_missing(grob_fn)) {
default_fn <- switch(piece_side,
die_face = basicDieGrob,
pyramid_top = basicPyramidTop,
pyramid_face = basicPyramidSide,
pyramid_back = basicPyramidSide,
pyramid_left = basicPyramidSide,
pyramid_right = basicPyramidSide,
basicTokenGrob)
grob_fn <- get_style_element("op_grob_fn", piece_side, private$cfg,
default_fn, suit, rank)
if (self$cache_op_fn) self$cache$set(key, grob_fn)
}
args <- list(piece_side = piece_side,
suit = suit,
rank = rank,
cfg = self,
x = x, y = y , z = z,
angle = angle, type = type,
width = width, height = height, depth = depth,
op_scale = op_scale, op_angle = op_angle)
grob <- do.call(grob_fn, args)
},
get_raster = function(piece_side, suit, rank, res=72) {
grob <- private$get_grob_normal(piece_side, suit, rank)
width <- self$get_width(piece_side, suit, rank)
height <- self$get_height(piece_side, suit, rank)
png_file <- tempfile(fileext=".png")
on.exit(unlink(png_file))
current_dev <- grDevices::dev.cur()
if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
args <- list(filename=png_file, width=width, height=height,
units="in", res=res, bg="transparent")
if (capabilities("cairo"))
args$type <- "cairo"
do.call(png, args)
grid.draw(grob)
invisible(grDevices::dev.off())
as.raster(png::readPNG(png_file))
},
rayrender = function(piece_side, suit, rank,
x, y, z, angle, axis_x, axis_y,
width, height, depth,
scale = 1, res = 72) {
key <- private$opt_cache_key(piece_side, suit, rank, "rayrender_fn")
rayrender_fn <- self$cache$get(key, key_missing())
if (is.key_missing(rayrender_fn)) {
rayrender_fn <- get_style_element("rayrender_fn", piece_side, private$cfg,
rr_piece_helper, suit, rank)
if (self$cache_obj_fn) self$cache$set(key, rayrender_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
scale = scale, res = res)
do.call(rayrender_fn, args)
},
rayvertex = function(piece_side, suit, rank,
x, y, z, angle, axis_x, axis_y,
width, height, depth,
scale = 1, res = 72) {
key <- private$opt_cache_key(piece_side, suit, rank, "rayvertex_fn")
rayvertex_fn <- self$cache$get(key, key_missing())
if (is.key_missing(rayvertex_fn)) {
rayvertex_fn <- get_style_element("rayvertex_fn", piece_side, private$cfg,
rv_piece_helper, suit, rank)
if (self$cache_obj_fn) self$cache$set(key, rayvertex_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
scale = scale, res = res)
do.call(rayvertex_fn, args)
},
rgl = function(piece_side, suit, rank,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
scale = 1, res = 72,
alpha = 1.0, lit = FALSE,
shininess = 50.0, textype = "rgba") {
key <- private$opt_cache_key(piece_side, suit, rank, "rgl_fn")
rgl_fn <- self$cache$get(key, key_missing())
if (is.key_missing(rgl_fn)) {
rgl_fn <- get_style_element("rgl_fn", piece_side, private$cfg,
rgl_piece_helper, suit, rank)
if (self$cache_obj_fn) self$cache$set(key, rgl_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
scale = scale, res = res, alpha = alpha,
lit = lit, shininess = shininess, textype = textype)
do.call(rgl_fn, args)
},
save_obj = function(piece_side, suit, rank,
x, y, z, angle, axis_x, axis_y,
width, height, depth,
filename = tempfile(fileext = ".obj"), res = 72) {
key <- private$opt_cache_key(piece_side, suit, rank, "obj_fn")
obj_fn <- self$cache$get(key, key_missing())
if (is.key_missing(obj_fn)) {
if (grepl("tile|coin|pawn|matchstick|bit|board|card|saucer", piece_side)) {
default_fn <- save_2s_obj
} else if (grepl("die", piece_side)) {
default_fn <- save_die_obj
} else if (piece_side == "pyramid_top") {
default_fn <- save_pt_obj
} else if (grepl("pyramid", piece_side)) {
default_fn <- save_ps_obj
} else {
default_fn <- NULL
}
obj_fn <- get_style_element("obj_fn", piece_side, private$cfg, default_fn, suit, rank)
if (is.null(obj_fn)) {
abort(paste("Don't know how to export ", piece_side, " to Wavefront OBJ format."))
}
if (self$cache_obj_fn) self$cache$set(key, obj_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
filename = filename, res = res)
do.call(obj_fn, args)
}),
active = list(
annotation_color = function(value) {
if (missing(value)) {
private$cfg$annotation_color %||% "black"
} else {
stopifnot(is.character(value))
private$cfg$annotation_color <- value
}
},
cache_grob = function(value) {
if (missing(value)) {
private$cache_grob_bool
} else {
private$cache_type(value, "cache_grob_bool", "grob$")
}
},
cache_grob_with_bleed_fn = function(value) {
if (missing(value)) {
private$cache_grob_with_bleed_fn_bool
} else {
private$cache_type(value, "cache_grob_with_bleed_fn_bool", "grob_with_bleed_fn$")
}
},
cache_obj_fn = function(value) {
if (missing(value)) {
private$cache_obj_fn_bool
} else {
private$cache_type(value, "cache_obj_fn_bool", "obj_fn$|rgl_fn$|rayrender_fn$")
}
},
cache_piece_opt = function(value) {
if (missing(value)) {
private$cache_piece_opt_bool
} else {
private$cache_type(value, "cache_piece_opt_bool", "piece_opt$")
}
},
cache_op_fn = function(value) {
if (missing(value)) {
private$cache_op_fn_bool
} else {
private$cache_type(value, "cache_op_fn_bool", "shadow$|op_grob_fn$")
}
},
coin_arrangement = function(value) {
if (missing(value)) {
as.numeric(private$cfg$coin_arrangement %||% 180)
} else {
private$cfg$coin_arrangement <- value
}
},
copyright = function(value) {
if (missing(value)) {
private$cfg$copyright
} else {
stopifnot(is.character(value))
private$cfg$copyright <- value
}
},
credit = function(value) {
if (missing(value)) {
private$cfg$credit
} else {
stopifnot(is.character(value))
private$cfg$credit <- value
}
},
description = function(value) {
if (missing(value)) {
private$cfg$description
} else {
stopifnot(is.character(value))
private$cfg$description <- value
}
},
die_arrangement = function(value) {
if (missing(value)) {
private$cfg$die_arrangement %||% "counter_down"
} else {
stopifnot(is.character(value))
private$cfg$die_arrangement <- value
}
},
fontfamily = function(value) {
if (missing(value))
private$cfg$fontfamily %||% "sans"
else
warn("Must set 'fontfamily' at initialization")
},
has_piecepack = function(value) {
if (missing(value)) {
self$has_coins && self$has_tiles && self$has_pawns && self$has_dice
} else {
stopifnot(is.logical(value))
self$has_coins <- value
self$has_tiles <- value
self$has_pawns <- value
self$has_dice <- value
}
},
lacks_rank = function(value) {
if (missing(value))
private$cfg$lacks_rank
else
warn("Must set 'lacks_rank' at initialization")
},
lacks_suit = function(value) {
if (missing(value))
private$cfg$lacks_suit
else
warn("Must set 'lacks_suit' at initialization")
},
n_ranks = function(value) {
if (missing(value))
private$cfg$n_ranks
else
warn("Must set 'n_ranks' at initialization")
},
n_suits = function(value) {
if (missing(value))
private$cfg$n_suits
else
warn("Must set 'n_suits' at initialization")
},
spdx_id = function(value) {
if (missing(value)) {
private$cfg$spdx_id
} else {
stopifnot(is.character(value))
check_spdx_id(value)
private$cfg$spdx_id <- value
}
},
title = function(value) {
if (missing(value)) {
private$cfg$title
} else {
stopifnot(is.character(value))
private$cfg$title <- value
}
}),
private = list(cfg = NULL, prefix = NULL,
cache_grob_bool = TRUE,
cache_grob_with_bleed_fn_bool = TRUE,
cache_obj_fn_bool = TRUE,
cache_piece_opt_bool = TRUE,
cache_op_fn_bool = TRUE,
n_suits_val = NULL,
n_ranks_val = NULL,
get_grob_normal = function(piece_side, suit, rank) {
rank <- impute_rank(piece_side, rank, self)
suit <- impute_suit(piece_side, suit, self)
key <- private$opt_cache_key(piece_side, suit, rank, "grob")
grob <- self$cache$get(key, key_missing())
if (is.key_missing(grob)) {
default_grob_fn <- switch(piece_side,
board_face = checkeredBoardGrobFn(8, 8),
board_back = linedBoardGrobFn(8, 8),
card_face = cardGrobFn(-1),
card_back = cardGrobFn(-1),
basicPieceGrob)
default_fn <- get_style_element("grob_fn", piece_side, private$cfg,
default_grob_fn, suit, rank)
grob_fn <- switch(piece_side,
die_layoutLF = dieLayoutGrobLF,
die_layoutRF = dieLayoutGrobRF,
suitdie_layoutLF = suitdieLayouGrobtLF,
suitdie_layoutRF = suitdieLayoutGrobRF,
suitrankdie_layoutLF = suitrankdieLayoutGrobLF,
suitrankdie_layoutRF = suitrankdieLayoutGrobRF,
pawn_layout = pawnLayoutGrob,
preview_layout = previewLayoutGrob,
pyramid_layout = pyramidLayoutGrob,
pyramid_top = pyramidTopGrob,
default_fn)
if (is.character(grob_fn))
grob_fn <- match.fun(grob_fn)
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self)
grob <- do.call(grob_fn, args)
if (!inherits(grob, "pp_grobCoords"))
class(grob) <- c("pp_grobCoords", class(grob))
if (self$cache_grob) self$cache$set(key, grob)
}
grob
},
get_grob_picture = function(piece_side, suit, rank) {
grob <- private$get_grob_normal(piece_side, suit, rank)
width <- self$get_width(piece_side, suit, rank)
height <- self$get_height(piece_side, suit, rank)
as_picture(grob, width, height)
},
get_grob_transformation = function(piece_side, suit, rank) {
grob <- private$get_grob_normal(piece_side, suit, rank)
width <- self$get_width(piece_side, suit, rank)
height <- self$get_height(piece_side, suit, rank)
vp <- viewport(width = inch(width), height = inch(height))
transformationGrob(grob, vp.define=vp)
},
opt_cache_key = function(piece_side, suit, rank, type) {
paste(private$prefix, piece_side, suit, rank, type, sep="-")
},
cache_type = function(value, private_key, cache_key) {
if (isTRUE(value)) {
private[[private_key]] <- TRUE
} else if (isFALSE(value)) {
private[[private_key]] <- FALSE
keys <- grep(cache_key, self$cache$keys(), value = TRUE)
for (key in keys) self$cache$remove(key)
} else {
abort("value was not a boolean")
}
})
)
trevorld/piecepackr documentation built on Jan. 4, 2024, 7:27 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions impute_suit impute_rank as.list.pp_cfg is_pp_cfg pp_cfg
Documented in is_pp_cfg pp_cfg
#' Configuration list R6 object
#'
#' `pp_cfg()` and `as_pp_cfg()` create piecepack configuration list R6 objects.
#' `is_pp_cfg()` returns `TRUE` if object is a piecepack configuration list R6 object.
#' `as.list()` will convert it into a list.
#'
#' `pp_cfg` R6 class objects serve the following purposes:
#'
#' * Customize the appearance of pieces drawn by `grid.piece()`.
#' * Speed up the drawing of graphics through use of caching.
#' * Allow the setting and querying of information about the board game components
#' that maybe of use to developers:
#'
#' + Number of suits
#' + Number of ranks
#' + Suit colors
#' + Which types of components are included and/or properly supported
#' + What would be a good color to use when adding annotations on top of these components.
#' + Title, Description, Copyright, License, and Credit metadata
#'
#' @section `pp_cfg` R6 Class Method Arguments:\describe{
#' \item{`piece_side`}{A string with piece and side separated by a underscore e.g. "coin_face".}
#' \item{`suit`}{Number of suit (starting from 1).}
#' \item{`rank`}{Number of rank (starting from 1).}
#' \item{`type`}{Which type of grob to return, either `"normal"`, `"picture"`, `"raster"`, or `"transformation"`.}
#' \item{`scale`}{"scale" factor}
#' \item{`alpha`}{"alpha" value}
#' }
#'
#' @section `pp_cfg` R6 Class Methods:\describe{
#' \item{`get_grob()`}{Returns a \code{grid} \dQuote{grob} for drawing the piece.}
#' \item{`get_piece_opt()`}{Returns a list with info useful for drawing the piece.}
#' \item{`get_suit_color()`}{Returns the suit colors.}
#' \item{`get_width()`, `get_height()`, `get_depth()`}{
#' Dimensions (of the bounding cube) of the piece in inches}
#' }
#'
#' @section \code{pp_cfg} R6 Class Fields and Active Bindings:\describe{
#' \item{`annotation_color`}{Suggestion of a good color to annotate with}
#' \item{`cache`}{Cache object which stores intermediate graphical calculations.
#' Default is a memory-cache that does not prune.
#' This can be replaced by another cache that
#' implements the cache API used by the `cachem` package}
#' \item{`cache_grob`}{Whether we should cache (2D) grobs}
#' \item{`cache_grob_with_bleed_fn`}{Whether we should cache the grob with bleed functions}
#' \item{`cache_piece_opt`}{Whether we should cache piece opt information}
#' \item{`cache_op_fn`}{Whether we should cache the oblique projection functions}
#' \item{`cache_obj_fn`}{Whether we should cache any 3D rendering functions}
#' \item{`copyright`}{Design copyright information}
#' \item{`credit`}{Design credits}
#' \item{`description`}{Design description}
#' \item{`fontfamily`}{Main font family}
#' \item{`has_bits`}{Whether we should assume this supports "bit" pieces}
#' \item{`has_boards`}{Whether we should assume this supports "board" pieces}
#' \item{`has_cards`}{Whether we should assume this supports "card" pieces}
#' \item{`has_coins`}{Whether we should assume this supports "coin" pieces}
#' \item{`has_dice`}{Whether we should assume this supports "die" pieces}
#' \item{`has_matchsticks`}{Whether we should assume this supports "matchstick" pieces}
#' \item{`has_pawns`}{Whether we should assume this supports "pawn" pieces}
#' \item{`has_piecepack`}{Binding which simultaneously checks/sets
#' `has_coins`, `has_tiles`, `has_pawns`, `has_dice`}
#' \item{`has_pyramids`}{Whether we should assume this supports "pyramid" pieces}
#' \item{`has_saucers`}{Whether we should assume this supports "saucer" pieces}
#' \item{`has_tiles`}{Whether we should assume this supports "tile" pieces}
#' \item{`spdx_id`}{SPDX Identifier for graphical design license.
#' See \url{https://spdx.org/licenses/} for full list.}
#' \item{`title`}{Design title}
#' }
#'
#' @section Defunct `pp_cfg` R6 Class attributes which have been removed:\describe{
#' \item{`cache_shadow`}{Use `cache_op_fn` instead}
#' \item{`i_unsuit`}{Instead add `1L` to `n_suits`}
#' \item{`get_pictureGrob()`}{Use `get_grob(..., type = "picture")` instead}
#' \item{`get_shadow_fn`}{`get_op_grob()` returns complete oblique projection grob}
#' }
#'
#' @seealso [game_systems()] for functions that return configuration list
#' objects for several game systems.
#' <https://trevorldavis.com/piecepackr/configuration-lists.html> for more details
#' about `piecepackr` configuration lists.
#' @param cfg List of configuration options
#' @examples
#' cfg <- pp_cfg(list(invert_colors=TRUE))
#' as.list(cfg)
#' is_pp_cfg(cfg)
#' as_pp_cfg(list(suit_color="darkred,black,darkgreen,darkblue,grey"))
#' cfg$get_suit_color(suit=3)
#' cfg$annotation_color
#' cfg$has_matchsticks
#' cfg$has_matchsticks <- TRUE
#' cfg$has_matchsticks
#' cfg$get_width("tile_back")
#' cfg$get_height("die_face")
#' cfg$get_depth("coin_face")
#' \donttest{# May take more than 5 seconds on CRAN servers
#' # `pp_cfg()` objects use a cache to speed up repeated drawing
#' pdf(tempfile(fileext = ".pdf"))
#' cfg <- list()
#' system.time(replicate(100, grid.piece("tile_back", 4, 4, cfg)))
#' cfg <- pp_cfg(list())
#' system.time(replicate(100, grid.piece("tile_back", 4, 4, cfg)))
#' invisible(dev.off())
#' }
#'
#' @export
pp_cfg <- function(cfg=list()) {
if (is_pp_cfg(cfg))
cfg
else
Config$new(cfg)
}
#' @rdname pp_cfg
#' @export
is_pp_cfg <- function(cfg) inherits(cfg, "pp_cfg")
#' @rdname pp_cfg
#' @export
as_pp_cfg <- pp_cfg
#' @export
as.list.pp_cfg <- function(x, ...) {
x$as_list()
}
default_lacks_suit <- c("tile_back", "saucer_back", "coin_face", "card_back")
default_lacks_rank <- c("tile_back", "coin_back", "card_back",
"pawn_face", "pawn_back", "belt_face",
"saucer_face", "saucer_back", "suitdie_face")
impute_rank <- function(piece_side, rank, cfg) {
ifelse(piece_side %in% cfg$lacks_rank,
cfg$n_ranks+1L,
ifelse(is.na(rank), 1L, min(rank, cfg$n_ranks+2L)))
}
impute_suit <- function(piece_side, suit, cfg) {
ifelse(piece_side %in% cfg$lacks_suit,
cfg$n_suits+1L,
ifelse(is.na(suit), 1L, min(suit, cfg$n_suits+2L)))
}
Config <- R6Class("pp_cfg",
public = list(
cache = NULL,
has_bits = FALSE,
has_boards = FALSE,
has_cards = FALSE,
has_coins = TRUE,
has_dice = TRUE,
has_matchsticks = FALSE,
has_pawns = TRUE,
has_pyramids = FALSE,
has_saucers = FALSE,
has_tiles = TRUE,
initialize = function(cfg=list()) {
warn_cfg(cfg)
self$cache <- Cache$new()
private$cfg <- cfg
private$cfg$n_suits <- cfg$n_suits %||% (length(get_suit_symbols(cfg=cfg, expand=FALSE)) - 1L)
private$cfg$n_ranks <- cfg$n_ranks %||% length(get_rank_symbols(cfg=cfg, expand=FALSE))
private$cfg$lacks_rank <- cleave2(cfg$lacks_rank %||% default_lacks_rank)
private$cfg$lacks_suit <- cleave2(cfg$lacks_suit %||% default_lacks_suit)
# so different cfg objects can share the same cache (with high probability)
private$prefix <- as.hexmode(sample.int(2147483647L, 1L, useHash=TRUE))
},
get_grob = function(piece_side, suit, rank,
type = c("normal", "picture", "raster", "transformation"),
...) {
type <- match.arg(type)
grob <- switch(type,
normal = private$get_grob_normal(piece_side, suit, rank),
picture = private$get_grob_picture(piece_side, suit, rank),
raster = to_rasterGrob(self$get_raster(piece_side, suit, rank, ...)),
transformation = private$get_grob_transformation(piece_side, suit, rank))
grob
},
get_grob_with_bleed = function(piece_side, suit, rank) {
rank <- impute_rank(piece_side, rank, self)
suit <- impute_suit(piece_side, suit, self)
key <- private$opt_cache_key(piece_side, suit, rank, "grob_with_bleed_fn")
grob_fn <- self$cache$get(key, key_missing())
if (is.key_missing(grob_fn)) {
default_grob_fn <- basicGrobWithBleed
grob_fn <- get_style_element("grob_with_bleed_fn", piece_side, private$cfg,
default_grob_fn, suit, rank)
if (is.character(grob_fn))
grob_fn <- match.fun(grob_fn)
if (self$cache_grob_with_bleed_fn) self$cache$set(key, grob_fn)
}
args <- list(piece_side = piece_side, suit = suit, rank = rank,
cfg = self)
do.call(grob_fn, args)
},
get_piece_opt = function(piece_side, suit=NA, rank=NA) {
if (is.na(rank)) rank <- 1L
if (is.na(suit)) suit <- self$n_suits + 1L
key <- private$opt_cache_key(piece_side, suit, rank, "piece_opt")
opt <- self$cache$get(key, key_missing())
if (is.key_missing(opt)) {
opt <- get_piece_opt_helper(piece_side, suit, rank, private$cfg)
if (self$cache_piece_opt) self$cache$set(key, opt)
}
opt
},
get_suit_color = function(suit=NULL) {
if (is.null(suit)) suit <- seq(self$n_suits)
colors <- character(length(suit))
for (ii in seq(along.with=suit)) {
colors[ii] <- get_suit_color_helper("pawn_face", suit[ii], rank=1, private$cfg)
}
colors
},
get_width = function(piece_side, suit=1, rank=1) {
key <- private$opt_cache_key(piece_side, suit, rank, "width")
width <- self$cache$get(key, key_missing())
if (!is.key_missing(width))
return(width)
if (grepl("die_layout", piece_side)) {
die_width <- self$get_width("die_face")
return(4 * die_width)
}
if (grepl("pyramid_layout", piece_side)) {
pyramid_height <- self$get_height("pyramid_face", rank=rank)
return(pyramid_height)
}
if (piece_side == "preview_layout") {
tile_width <- self$get_width("tile_face")
return(3 * tile_width)
}
piece <- get_piece(piece_side)
if (grepl("_left$|_right$", piece_side) && piece != "pyramid") {
ps <- paste0(piece, "_face")
return(self$get_height(ps, suit=suit, rank=rank))
}
default <- switch(piece,
belt = 0.75 * pi, # so can wrap around 3/4" diameter pawns
bit = 0.75,
board = 8,
card = 2.5,
coin = 0.75,
die = 0.5,
matchstick = MATCHSTICK_WIDTHS[rank],
pawn = 0.5,
pyramid = PYRAMID_WIDTHS[rank],
saucer = 0.75, # better than 7/8" for diagrams of hex games played with coin+pawn
suitdie = 0.5,
tile = 2,
abort(paste("Don't know width of piece", piece)))
width <- get_style_element("width", piece_side, private$cfg, default, suit, rank)
self$cache$set(key, width)
width
},
get_height = function(piece_side, suit=1, rank=1) {
key <- private$opt_cache_key(piece_side, suit, rank, "height")
height <- self$cache$get(key, key_missing())
if (!is.key_missing(height))
return(height)
if (grepl("die_layout", piece_side)) {
die_height <- self$get_height("die_face")
return(3 * die_height)
}
if (grepl("pyramid_layout", piece_side)) {
pyramid_height <- self$get_height("pyramid_face", rank=rank)
pyramid_width <- self$get_width("pyramid_face", rank=rank)
pyramid_diagonal <- sqrt(pyramid_height^2 + (0.5*pyramid_width)^2)
return(2 * pyramid_diagonal)
}
if (grepl("pyramid_top", piece_side)) {
pyramid_width <- self$get_width("pyramid_face", rank=rank)
return(pyramid_width)
}
if (grepl("pawn_layout", piece_side)) {
pawn_height <- self$get_height("pawn_face")
return((2.5 / (7/8)) * pawn_height)
}
if (piece_side == "preview_layout") {
tile_height <- self$get_height("tile_face")
return(3 * tile_height)
}
piece <- get_piece(piece_side)
if (grepl("_top$|_base$|_left$|_right$", piece_side) && piece != "pyramid") {
ps <- paste0(piece, "_face")
return(self$get_depth(ps, suit=suit, rank=rank))
}
width <- self$get_width(piece_side, suit, rank)
if (piece == "matchstick") {
W <- ifelse(rank == 1, 0.5*width, width)
S <- 0.5 * self$get_width("tile_face")
ms_default <- (c(2*W, S-W, sqrt(2)*S-W, 2*S-W, sqrt(5*S^2)-W, 2*sqrt(2)*S-W)[rank])
}
default <- switch(piece,
belt = 0.5,
bit = width,
board = width,
card = 1.4 * width,
coin = width,
die = width,
matchstick = ms_default,
pawn = 0.875,
pyramid = 1.538842 * width,
saucer = width,
suitdie = width,
tile = width,
abort(paste("Don't know height of piece", piece))) #nocov
height <- get_style_element("height", piece_side, private$cfg, default, suit, rank)
self$cache$set(key, height)
height
},
get_depth = function(piece_side, suit=1, rank=1) {
key <- private$opt_cache_key(piece_side, suit, rank, "depth")
depth <- self$cache$get(key, key_missing())
if (!is.key_missing(depth))
return(depth)
width <- self$get_width(piece_side, suit, rank)
if (grepl("pyramid", piece_side)) {
height <- self$get_height("pyramid_face", rank=rank)
if (piece_side == "pyramid_top") {
return(sqrt(height^2 - (0.5*width)^2))
} else {
theta <- 2 * asin(0.5 * width / height)
return(sin(theta) * height)
}
}
piece <- get_piece(piece_side)
if (grepl("_top$|_base$", piece_side)) {
ps <- paste0(piece, "_face")
return(self$get_height(ps, suit=suit, rank=rank))
} else if (grepl("_left$|_right$", piece_side)) {
ps <- paste0(piece, "_face")
return(self$get_width(ps, suit=suit, rank=rank))
}
default <- switch(piece,
bit = 0.25,
board = 0.25,
card = 0.01181102, # 3 mm
coin = 0.125,
die = width,
matchstick = width,
pawn = 0.25,
saucer = 0.125,
suitdie = width,
tile = 0.25,
0)
depth <- get_style_element("depth", piece_side, private$cfg, default, suit, rank)
self$cache$set(key, depth)
depth
},
as_list = function() private$cfg,
print = function() {
for (name in sort(names(private$cfg))) {
if (is.function(private$cfg[[name]])) {
cat(paste0("$", name, " : ", "a function", "\n"))
} else {
cat(paste0("$", name, " : ", paste(private$cfg[[name]], collapse=",")), "\n")
}
}
},
get_op_grob = function(piece_side, suit, rank,
x, y, z, angle, type,
width, height, depth,
op_scale, op_angle) {
key <- private$opt_cache_key(piece_side, suit, rank, "op_grob")
grob_fn <- self$cache$get(key, key_missing())
if (is.key_missing(grob_fn)) {
default_fn <- switch(piece_side,
die_face = basicDieGrob,
pyramid_top = basicPyramidTop,
pyramid_face = basicPyramidSide,
pyramid_back = basicPyramidSide,
pyramid_left = basicPyramidSide,
pyramid_right = basicPyramidSide,
basicTokenGrob)
grob_fn <- get_style_element("op_grob_fn", piece_side, private$cfg,
default_fn, suit, rank)
if (self$cache_op_fn) self$cache$set(key, grob_fn)
}
args <- list(piece_side = piece_side,
suit = suit,
rank = rank,
cfg = self,
x = x, y = y , z = z,
angle = angle, type = type,
width = width, height = height, depth = depth,
op_scale = op_scale, op_angle = op_angle)
grob <- do.call(grob_fn, args)
},
get_raster = function(piece_side, suit, rank, res=72) {
grob <- private$get_grob_normal(piece_side, suit, rank)
width <- self$get_width(piece_side, suit, rank)
height <- self$get_height(piece_side, suit, rank)
png_file <- tempfile(fileext=".png")
on.exit(unlink(png_file))
current_dev <- grDevices::dev.cur()
if (current_dev > 1) on.exit(grDevices::dev.set(current_dev))
args <- list(filename=png_file, width=width, height=height,
units="in", res=res, bg="transparent")
if (capabilities("cairo"))
args$type <- "cairo"
do.call(png, args)
grid.draw(grob)
invisible(grDevices::dev.off())
as.raster(png::readPNG(png_file))
},
rayrender = function(piece_side, suit, rank,
x, y, z, angle, axis_x, axis_y,
width, height, depth,
scale = 1, res = 72) {
key <- private$opt_cache_key(piece_side, suit, rank, "rayrender_fn")
rayrender_fn <- self$cache$get(key, key_missing())
if (is.key_missing(rayrender_fn)) {
rayrender_fn <- get_style_element("rayrender_fn", piece_side, private$cfg,
rr_piece_helper, suit, rank)
if (self$cache_obj_fn) self$cache$set(key, rayrender_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
scale = scale, res = res)
do.call(rayrender_fn, args)
},
rayvertex = function(piece_side, suit, rank,
x, y, z, angle, axis_x, axis_y,
width, height, depth,
scale = 1, res = 72) {
key <- private$opt_cache_key(piece_side, suit, rank, "rayvertex_fn")
rayvertex_fn <- self$cache$get(key, key_missing())
if (is.key_missing(rayvertex_fn)) {
rayvertex_fn <- get_style_element("rayvertex_fn", piece_side, private$cfg,
rv_piece_helper, suit, rank)
if (self$cache_obj_fn) self$cache$set(key, rayvertex_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
scale = scale, res = res)
do.call(rayvertex_fn, args)
},
rgl = function(piece_side, suit, rank,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
scale = 1, res = 72,
alpha = 1.0, lit = FALSE,
shininess = 50.0, textype = "rgba") {
key <- private$opt_cache_key(piece_side, suit, rank, "rgl_fn")
rgl_fn <- self$cache$get(key, key_missing())
if (is.key_missing(rgl_fn)) {
rgl_fn <- get_style_element("rgl_fn", piece_side, private$cfg,
rgl_piece_helper, suit, rank)
if (self$cache_obj_fn) self$cache$set(key, rgl_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
scale = scale, res = res, alpha = alpha,
lit = lit, shininess = shininess, textype = textype)
do.call(rgl_fn, args)
},
save_obj = function(piece_side, suit, rank,
x, y, z, angle, axis_x, axis_y,
width, height, depth,
filename = tempfile(fileext = ".obj"), res = 72) {
key <- private$opt_cache_key(piece_side, suit, rank, "obj_fn")
obj_fn <- self$cache$get(key, key_missing())
if (is.key_missing(obj_fn)) {
if (grepl("tile|coin|pawn|matchstick|bit|board|card|saucer", piece_side)) {
default_fn <- save_2s_obj
} else if (grepl("die", piece_side)) {
default_fn <- save_die_obj
} else if (piece_side == "pyramid_top") {
default_fn <- save_pt_obj
} else if (grepl("pyramid", piece_side)) {
default_fn <- save_ps_obj
} else {
default_fn <- NULL
}
obj_fn <- get_style_element("obj_fn", piece_side, private$cfg, default_fn, suit, rank)
if (is.null(obj_fn)) {
abort(paste("Don't know how to export ", piece_side, " to Wavefront OBJ format."))
}
if (self$cache_obj_fn) self$cache$set(key, obj_fn)
}
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self,
x = x, y = y, z = z,
angle = angle, axis_x = axis_x, axis_y = axis_y,
width = width, height = height, depth = depth,
filename = filename, res = res)
do.call(obj_fn, args)
}),
active = list(
annotation_color = function(value) {
if (missing(value)) {
private$cfg$annotation_color %||% "black"
} else {
stopifnot(is.character(value))
private$cfg$annotation_color <- value
}
},
cache_grob = function(value) {
if (missing(value)) {
private$cache_grob_bool
} else {
private$cache_type(value, "cache_grob_bool", "grob$")
}
},
cache_grob_with_bleed_fn = function(value) {
if (missing(value)) {
private$cache_grob_with_bleed_fn_bool
} else {
private$cache_type(value, "cache_grob_with_bleed_fn_bool", "grob_with_bleed_fn$")
}
},
cache_obj_fn = function(value) {
if (missing(value)) {
private$cache_obj_fn_bool
} else {
private$cache_type(value, "cache_obj_fn_bool", "obj_fn$|rgl_fn$|rayrender_fn$")
}
},
cache_piece_opt = function(value) {
if (missing(value)) {
private$cache_piece_opt_bool
} else {
private$cache_type(value, "cache_piece_opt_bool", "piece_opt$")
}
},
cache_op_fn = function(value) {
if (missing(value)) {
private$cache_op_fn_bool
} else {
private$cache_type(value, "cache_op_fn_bool", "shadow$|op_grob_fn$")
}
},
coin_arrangement = function(value) {
if (missing(value)) {
as.numeric(private$cfg$coin_arrangement %||% 180)
} else {
private$cfg$coin_arrangement <- value
}
},
copyright = function(value) {
if (missing(value)) {
private$cfg$copyright
} else {
stopifnot(is.character(value))
private$cfg$copyright <- value
}
},
credit = function(value) {
if (missing(value)) {
private$cfg$credit
} else {
stopifnot(is.character(value))
private$cfg$credit <- value
}
},
description = function(value) {
if (missing(value)) {
private$cfg$description
} else {
stopifnot(is.character(value))
private$cfg$description <- value
}
},
die_arrangement = function(value) {
if (missing(value)) {
private$cfg$die_arrangement %||% "counter_down"
} else {
stopifnot(is.character(value))
private$cfg$die_arrangement <- value
}
},
fontfamily = function(value) {
if (missing(value))
private$cfg$fontfamily %||% "sans"
else
warn("Must set 'fontfamily' at initialization")
},
has_piecepack = function(value) {
if (missing(value)) {
self$has_coins && self$has_tiles && self$has_pawns && self$has_dice
} else {
stopifnot(is.logical(value))
self$has_coins <- value
self$has_tiles <- value
self$has_pawns <- value
self$has_dice <- value
}
},
lacks_rank = function(value) {
if (missing(value))
private$cfg$lacks_rank
else
warn("Must set 'lacks_rank' at initialization")
},
lacks_suit = function(value) {
if (missing(value))
private$cfg$lacks_suit
else
warn("Must set 'lacks_suit' at initialization")
},
n_ranks = function(value) {
if (missing(value))
private$cfg$n_ranks
else
warn("Must set 'n_ranks' at initialization")
},
n_suits = function(value) {
if (missing(value))
private$cfg$n_suits
else
warn("Must set 'n_suits' at initialization")
},
spdx_id = function(value) {
if (missing(value)) {
private$cfg$spdx_id
} else {
stopifnot(is.character(value))
check_spdx_id(value)
private$cfg$spdx_id <- value
}
},
title = function(value) {
if (missing(value)) {
private$cfg$title
} else {
stopifnot(is.character(value))
private$cfg$title <- value
}
}),
private = list(cfg = NULL, prefix = NULL,
cache_grob_bool = TRUE,
cache_grob_with_bleed_fn_bool = TRUE,
cache_obj_fn_bool = TRUE,
cache_piece_opt_bool = TRUE,
cache_op_fn_bool = TRUE,
n_suits_val = NULL,
n_ranks_val = NULL,
get_grob_normal = function(piece_side, suit, rank) {
rank <- impute_rank(piece_side, rank, self)
suit <- impute_suit(piece_side, suit, self)
key <- private$opt_cache_key(piece_side, suit, rank, "grob")
grob <- self$cache$get(key, key_missing())
if (is.key_missing(grob)) {
default_grob_fn <- switch(piece_side,
board_face = checkeredBoardGrobFn(8, 8),
board_back = linedBoardGrobFn(8, 8),
card_face = cardGrobFn(-1),
card_back = cardGrobFn(-1),
basicPieceGrob)
default_fn <- get_style_element("grob_fn", piece_side, private$cfg,
default_grob_fn, suit, rank)
grob_fn <- switch(piece_side,
die_layoutLF = dieLayoutGrobLF,
die_layoutRF = dieLayoutGrobRF,
suitdie_layoutLF = suitdieLayouGrobtLF,
suitdie_layoutRF = suitdieLayoutGrobRF,
suitrankdie_layoutLF = suitrankdieLayoutGrobLF,
suitrankdie_layoutRF = suitrankdieLayoutGrobRF,
pawn_layout = pawnLayoutGrob,
preview_layout = previewLayoutGrob,
pyramid_layout = pyramidLayoutGrob,
pyramid_top = pyramidTopGrob,
default_fn)
if (is.character(grob_fn))
grob_fn <- match.fun(grob_fn)
args <- list(piece_side = piece_side,
suit = suit, rank = rank, cfg = self)
grob <- do.call(grob_fn, args)
if (!inherits(grob, "pp_grobCoords"))
class(grob) <- c("pp_grobCoords", class(grob))
if (self$cache_grob) self$cache$set(key, grob)
}
grob
},
get_grob_picture = function(piece_side, suit, rank) {
grob <- private$get_grob_normal(piece_side, suit, rank)
width <- self$get_width(piece_side, suit, rank)
height <- self$get_height(piece_side, suit, rank)
as_picture(grob, width, height)
},
get_grob_transformation = function(piece_side, suit, rank) {
grob <- private$get_grob_normal(piece_side, suit, rank)
width <- self$get_width(piece_side, suit, rank)
height <- self$get_height(piece_side, suit, rank)
vp <- viewport(width = inch(width), height = inch(height))
transformationGrob(grob, vp.define=vp)
},
opt_cache_key = function(piece_side, suit, rank, type) {
paste(private$prefix, piece_side, suit, rank, type, sep="-")
},
cache_type = function(value, private_key, cache_key) {
if (isTRUE(value)) {
private[[private_key]] <- TRUE
} else if (isFALSE(value)) {
private[[private_key]] <- FALSE
keys <- grep(cache_key, self$cache$keys(), value = TRUE)
for (key in keys) self$cache$remove(key)
} else {
abort("value was not a boolean")
}
})
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.