Nothing
R/utils-pips.R
In piecepackr: Board Game Graphics
Defines functions
makeContent.pipped
pippedGrobFn
makeContent.domino_side
dominoGrobFn
faceGrob
makeContent.face_card_side
faceCardGrobFn
jokerGrob
makeContent.joker_card_side
jokerCardGrobFn
makeContent.card_side
cardGrobFn
xya_pips_dominoes
xya_pips_cards
#' @importFrom tibble tibble
xya_pips_cards <- function(n_pips) {
if (n_pips == 0) {
return(tibble(x = numeric(0), y = numeric(0), angle = numeric(0)))
}
switch(n_pips,
tibble(x = 0.5, y = 0.5, angle = 0), # 1
tibble(x = 0.5, y = c(0.2, 0.8), angle = c(180, 0)), # 2
tibble(x = 0.5, y = c(0.2, 0.5, 0.8), angle = c(180, 0, 0)), # 3
tibble(x = rep(c(0.25, 0.75), 2),
y = rep(c(0.2, 0.8), each=2), # 4
angle = rep(c(180, 0), each=2)),
tibble(x = c(rep(c(0.25, 0.75), 2), 0.5), # 5
y = c(rep(c(0.2, 0.8), each=2), 0.5),
angle = c(rep(180, 2), rep(0, 3))),
tibble(x = rep(c(0.25, 0.75), 3),
y = rep(c(0.2, 0.5, 0.8), each=2), # 6
angle = c(rep(180, 2), rep(0, 4))),
tibble(x = c(rep(c(0.25, 0.75), 3), 0.5), # 7
y = c(rep(c(0.2, 0.5, 0.75), each=2), 0.55),
angle = c(rep(180, 2), rep(0, 5))),
tibble(x = rep(c(0.25, 0.75), 4), # 8
y = rep(c(0.2, 0.4, 0.6, 0.8), each=2),
angle = c(rep(180, 4), rep(0, 4))),
tibble(x = c(rep(c(0.25, 0.75), 4), 0.5), # 9
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.7),
angle = c(rep(180, 4), rep(0, 5))),
tibble(x = c(0.5, rep(c(0.25, 0.75), 4), 0.5), # 10
y = c(0.3, rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.7),
angle = c(rep(180, 5), rep(0, 5))),
abort(paste0("Don't know pip pattern for ", n_pips, " pips"))
)
}
xya_pips_dominoes <- function(n_pips, die = FALSE, chinese = FALSE, other_pips = NULL) {
if (n_pips == 0) {
return(tibble(x = numeric(0), y = numeric(0), angle = numeric(0)))
}
if (die && !chinese) {
high <- 0.75
} else if (chinese && die) {
if (n_pips == 4) {
high <- 0.65
} else if (n_pips == 6) {
high <- 0.75
} else {
high <- 0.68
}
} else {
high <- 0.78
}
low <- 1 - high
if (chinese && !die) {
low <- 0.2
if (n_pips == 3 && other_pips < 5) {
high <- 1.0
} else if (n_pips == 4 && other_pips == 4) {
high <- 0.75
} else {
high <- 0.84
}
}
if (chinese && die && n_pips == 6) {
left <- 0.36
} else if (chinese && !die) {
left <- 0.30
} else {
left <- low
}
right <- 1 - left
mid <- 0.5 * (high + low)
switch(n_pips,
if (chinese && !die)
tibble(x = 0.5, y = low, angle = 0)
else
tibble(x = 0.5, y = mid, angle = 0), # 1
if (chinese)
if (die)
tibble(x = 0.5, y = c(low, high), angle = c(0, 180))
else
tibble(x = c(left, right), y = low, angle = c(0, 180))
else
tibble(x = c(left, right), y = c(high, low), angle = c(0, 180)), # 2
tibble(x = c(left, 0.5, right),
y = c(high, mid, low),
angle = c(0, 0, 180)), # 3
if (chinese && !die && other_pips != 4)
tibble(x = rep(c(left, right), 2), # 4
y = rep(c(low, mid), each=2),
angle = rep(c(180, 0), each=2))
else
tibble(x = rep(c(left, right), 2), # 4
y = rep(c(low, high), each=2),
angle = rep(c(180, 0), each=2)),
tibble(x = c(rep(c(left, right), 2), 0.5), # 5
y = c(rep(c(low, high), each=2), mid),
angle = c(rep(180, 2), rep(0, 3))),
tibble(x = rep(c(left, right), 3),
y = rep(c(low, mid, high), each=2), # 6
angle = c(rep(180, 2), rep(0, 4))),
tibble(x = c(rep(c(left, right), 3), 0.5), # 7
y = c(rep(c(low, 0.5, high), each=2), 0.50),
angle = c(rep(180, 2), rep(0, 5))),
tibble(x = c(0.5, rep(c(left, right), 3), 0.5), # 8
y = c(low, rep(c(low, 0.5, high), each=2), high),
angle = c(rep(180, 3), rep(0, 5))),
tibble(x = c(rep(c(left, 0.5, right), 3)), # 9
y = c(rep(c(low, 0.5, high), each=3)),
angle = c(rep(180, 3), rep(0, 6))),
tibble(x = c(0.5, rep(c(0.20, 0.80), 4), 0.5), # 10
y = c(0.2, rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.8),
angle = c(rep(180, 5), rep(0, 5))),
tibble(x = c(0.5, rep(c(0.20, 0.80), 4), 0.5, 0.5), # 11
y = c(0.2, rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.5, 0.8),
angle = c(rep(180, 5), rep(0, 6))),
tibble(x = c(rep(c(0.20, 0.5, 0.80), 4)), # 12
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=3)),
angle = c(rep(180, 6), rep(0, 6))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 3), 0.5), # 13
y = c(rep(c(0.2, 0.4, 0.6), each=4), 0.8),
angle = c(rep(180, 8), rep(0, 5))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 3), 0.3, 0.7), # 14
y = c(rep(c(0.2, 0.4, 0.6), each=4), 0.8, 0.8),
angle = c(rep(180, 8), rep(0, 6))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 3), 0.3, 0.5, 0.7), # 15
y = c(rep(c(0.2, 0.4, 0.6), each=4), 0.8, 0.8, 0.8),
angle = c(rep(180, 8), rep(0, 7))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 4)), # 16
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=4)),
angle = c(rep(180, 8), rep(0, 8))),
tibble(x = c(rep(c(0.140, 0.340, 0.660, 0.860), 4), 0.5), # 17
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=4), 0.5),
angle = c(rep(180, 8), rep(0, 9))),
tibble(x = c(rep(c(0.140, 0.340, 0.660, 0.860), 4), 0.5, 0.5), # 18
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=4), 0.3, 0.7),
angle = c(rep(180, 8), rep(0, 8), 180, 0)),
abort(paste0("Don't know pip pattern for ", n_pips, " pips"))
)
}
cardGrobFn <- function(rank_offset = 0, type = "card", grob_type = "text") {
force(type)
force(rank_offset)
force(grob_type)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt=opt,
piece_side=piece_side, suit=suit, rank=rank, cfg=cfg,
type=type, rank_offset=rank_offset, grob_type=grob_type,
scale=1, border=TRUE,
cl=c("card_side", "basic_piece_side"))
}
}
#' @export
makeContent.card_side <- function(x) {
opt <- x$opt
type <- x$type
rank_offset <- x$rank_offset
grob_type <- x$grob_type
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name = "background")
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
gp_rank <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8)
rank_grob <- textGrob(label = opt$ps_text, gp = gp_rank,
x = c(0.1, 0.9), y = c(0.9, 0.1), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "rank")
gp_suit <- gpar(col = opt$dm_color, fontsize = opt$dm_fontsize,
fontfamily = opt$dm_fontfamily, fontface = opt$dm_fontface)
suit_grob <- textGrob(label = opt$dm_text, gp = gp_suit,
x = c(0.1, 0.9), y = c(0.8, 0.2), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "suit")
# Pips
tfn <- pippedGrobFn(rank_offset, type, grob_type, border = FALSE, mat = FALSE)
pip_grob <- tfn(x$piece_side, x$suit, x$rank, x$cfg)
pip_grob <- grid::editGrob(pip_grob,
vp=viewport(height = 1.0, width = 0.80, gp=gpar(cex=1.8)), name = "pips")
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name = "border")
} else {
border_grob <- nullGrob(name = "border")
}
gl <- gList(background_grob, pip_grob, rank_grob, suit_grob, mat_grob, border_grob)
setChildren(x, gl)
}
jokerCardGrobFn <- function(star = TRUE) {
force(star)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt = opt, star = star,
scale = 1, border = TRUE,
cl=c("joker_card_side", "basic_piece_side"))
}
}
#' @export
makeContent.joker_card_side <- function(x) {
opt <- x$opt
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name = "background")
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
gp_rank <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8)
rank_grob <- textGrob(label = opt$ps_text, gp = gp_rank,
x = c(0.1, 0.9), y = c(0.9, 0.1), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "rank")
# Joker
joker_grob <- jokerGrob(opt, x$star)
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name = "border")
} else {
border_grob <- nullGrob(name = "border")
}
gl <- gList(background_grob, joker_grob, rank_grob, mat_grob, border_grob)
setChildren(x, gl)
}
jokerGrob <- function(opt, star = TRUE) {
gp_meeple <- gpar(col = opt$ps_color, lwd = 4)
vp_meeple <- viewport(height=inch(1.3), width=inch(1.2), y = 0.4)
meeple_grob <- pp_shape("meeple")$shape(gp=gp_meeple, vp=vp_meeple)
gp_triangle <- gpar(fill = opt$ps_color, col = NA_character_)
y_triangle <- unit(0.4, "npc") + inch(0.5 * 1.3) + inch(0.5 * 0.8) + inch(-0.10)
vp_triangle <- viewport(height=inch(0.8), width=inch(0.45), y = y_triangle)
triangle_grob <- pp_shape("pyramid")$shape(gp=gp_triangle, vp=vp_triangle)
y_circle <- y_triangle + inch(0.5 * 0.8) + inch(0.5 * 0.2) + inch(-0.02)
vp_circle <- viewport(height=inch(0.2), width=inch(0.2), y = y_circle)
circle_grob <- circleGrob(vp = vp_circle, gp = gpar(col = opt$ps_color, lwd = 4))
if (star) {
star_grob <- pp_shape("concave5")$shape(gp = gp_triangle, vp = vp_circle)
} else {
star_grob <- NULL
}
grobTree(meeple_grob, triangle_grob, circle_grob, star_grob,
vp = viewport(width=0.8, height=0.9), cl = "joker")
}
faceCardGrobFn <- function(label = "", placement = "high") {
force(label)
force(placement)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt=opt, label=label, placement=placement,
scale=scale, border=TRUE,
cl=c("face_card_side", "basic_piece_side"))
}
}
#' @export
makeContent.face_card_side <- function(x) {
opt <- x$opt
label <- x$label
placement <- x$placement
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name = "background")
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
gp_rank <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8)
rank_grob <- textGrob(label = opt$ps_text, gp = gp_rank,
x = c(0.1, 0.9), y = c(0.9, 0.1), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "rank")
gp_suit <- gpar(col = opt$dm_color, fontsize = opt$dm_fontsize,
fontfamily = opt$dm_fontfamily, fontface = opt$dm_fontface)
suit_grob <- textGrob(label = opt$dm_text, gp = gp_suit,
x = c(0.1, 0.9), y = c(0.8, 0.2), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "suit")
# Face
top_grob <- faceGrob(opt, label, placement)
top_grob <- grid::editGrob(top_grob,
vp=viewport(y=0.75, height = 0.5, width = 0.80), name = "top")
bot_grob <- faceGrob(opt, label, placement)
bot_grob <- grid::editGrob(top_grob,
vp=viewport(y=0.25, height = 0.5, width = 0.80, angle = 180), name = "bottom")
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name = "border")
} else {
border_grob <- nullGrob(name = "border")
}
gl <- gList(background_grob, top_grob, bot_grob, rank_grob,
suit_grob, mat_grob, border_grob)
setChildren(x, gl)
}
faceGrob <- function(opt, label = "", placement = "high") {
if (placement == "high") {
y <- 0.7
x_meeple <- 0.5
y_meeple <- 0.3
in_meeple <- 1
cex <- 1.5
} else {
y <- 0.25
x_meeple <- 0.57
y_meeple <- 0.42
in_meeple <- 0.6
cex <- 3.0
}
rot <- ifelse(label %in% c("\u046a", "\u050a"), 180, 0)
gp_label <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8, cex = cex)
label_grob <- textGrob(label = label, gp = gp_label, x = 0.5, y = y,
hjust = 0.5, vjust = 0.5, rot = rot, name = "label")
gp_suit <- gpar(col = opt$dm_color, fontsize = opt$dm_fontsize,
fontfamily = opt$dm_fontfamily, fontface = opt$dm_fontface,
cex = in_meeple)
suit_grob <- textGrob(label = opt$dm_text, gp = gp_suit, x = x_meeple, y = y_meeple,
hjust = 0.5, vjust = 0.5, name = "suit")
gp_meeple <- gpar(col = opt$ps_color, lwd = 4)
vp_meeple <- viewport(height=inch(in_meeple), width=inch(in_meeple), x = x_meeple, y = y_meeple)
meeple_grob <- pp_shape("meeple")$shape(gp = gp_meeple, vp = vp_meeple)
grobTree(meeple_grob, label_grob, suit_grob, cl="face")
}
dominoGrobFn <- function(rank_offset = 0, type = "domino", grob_type = "circle") {
force(rank_offset)
force(type)
force(grob_type)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt=opt, cfg=cfg, suit=suit, rank=rank,
type=type, rank_offset=rank_offset, grob_type=grob_type,
scale=1, border=TRUE,
cl=c("domino_side", "basic_piece_side"))
}
}
#' @export
makeContent.domino_side <- function(x) {
opt <- x$opt
suit <- x$suit
rank <- x$rank
type <- x$type
rank_offset <- x$rank_offset
grob_type <- x$grob_type
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
if (type == "domino_chinese")
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name="background")
else
background_grob <- NULL
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
# Top (Rank)
tfn <- pippedGrobFn(rank_offset, type, grob_type, border = FALSE, mat = FALSE,
background = !(type == "domino_chinese"),
other_pips = suit)
top_grob <- tfn("tile_face", rank, rank, x$cfg)
top_grob <- grid::editGrob(top_grob,
vp=viewport(height = 0.5, y = 0.75, angle = 180), name="top_rank")
# Bottom (Suit)
bfn <- pippedGrobFn(rank_offset, type, grob_type, border = FALSE, mat = FALSE,
background = !(type == "domino_chinese"),
other_pips = rank)
bot_grob <- bfn("tile_face", suit, suit, x$cfg)
bot_grob <- grid::editGrob(bot_grob,
vp=viewport(height = 0.5, y = 0.25), name="bottom_suit")
gp_gl <- gpar(col = opt$gridline_color, lex = opt$gridline_lex)
gl_grob <- segmentsGrob(x0=0.1, x1=0.9, y0 = 0.5, y1 = 0.5, gp=gp_gl, name="gridlines")
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name="border")
} else {
border_grob <- nullGrob(name="border")
}
gl <- gList(background_grob, top_grob, bot_grob, gl_grob, mat_grob, border_grob)
setChildren(x, gl)
}
pippedGrobFn <- function(rank_offset = 0, type = "die", grob_type = "circle",
border = TRUE, mat = TRUE, background = TRUE,
other_pips = NULL) {
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt = opt, n_pips = rank + rank_offset, type = type, grob_type = grob_type,
border = border, mat = mat, background = background,
other_pips = other_pips + rank_offset,
name = NULL, gp = gpar(), vp = NULL, cl = "pipped")
}
}
#' @export
makeContent.pipped <- function(x) {
opt <- x$opt
if (x$type == "card") {
xya <- xya_pips_cards(x$n_pips)
} else if (x$type == "die") {
xya <- xya_pips_dominoes(x$n_pips, die = TRUE)
} else if (x$type == "die_chinese") {
xya <- xya_pips_dominoes(x$n_pips, die = TRUE, chinese = TRUE)
} else if (x$type == "domino_chinese") {
xya <- xya_pips_dominoes(x$n_pips, die = FALSE, chinese = TRUE,
other_pips = x$other_pips)
} else {
xya <- xya_pips_dominoes(x$n_pips)
}
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
# Background
if (x$background) {
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name="background")
} else {
background_grob <- NULL
}
# Mat
if (x$mat) {
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
} else {
mat_grob <- NULL
}
# Pips
if (nrow(xya) > 0) {
if (x$grob_type == "circle") {
if (x$type == "die_chinese" && (x$n_pips == 1 || x$n_pips == 4)) {
pip_color <- "#D55E00" # or just use "red"?
} else if (x$type == "domino_chinese" && (x$n_pips == 1 || x$n_pips == 4)) {
pip_color <- "#D55E00" # or just use "red"?
} else if (x$type == "domino_chinese" && x$n_pips == 6 && x$other_pips == 6) {
pip_color <- rep(c(opt$dm_color, "#D55E00"), 3L)
} else {
pip_color <- opt$dm_color
}
gp_pip <- gpar(col=pip_color, fill=pip_color)
if (x$type != "card" && x$n_pips > 9) {
r <- 0.06
} else if (x$type == "die_chinese") {
if (x$n_pips == 1) {
r <- 0.20
} else if (x$n_pips == 2) {
r <- 0.10
} else {
r <- 0.10
}
} else if (x$type == "domino_chinese") {
r <- 0.16
} else {
r <- 0.08
}
pip_grob <- circleGrob(x=xya$x, y=xya$y, r=r, gp=gp_pip, name="pips")
} else {
gp_pip <- gpar(col=opt$dm_color, fontsize=opt$dm_fontsize,
fontfamily=opt$dm_fontfamily, fontface=opt$dm_fontface)
pip_grob <- textGrob(opt$dm_text, x=xya$x, y=xya$y, rot = xya$angle,
gp = gp_pip, hjust = 0.5, vjust = 0.5, name="pips")
}
} else {
pip_grob <- nullGrob(name="pips")
}
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name="border")
} else {
border_grob <- NULL
}
gl <- gList(background_grob, mat_grob, pip_grob, border_grob)
setChildren(x, gl)
}
Try the piecepackr package in your browser
Any scripts or data that you put into this service are public.
piecepackr documentation built on Sept. 11, 2024, 9:09 p.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 makeContent.pipped pippedGrobFn makeContent.domino_side dominoGrobFn faceGrob makeContent.face_card_side faceCardGrobFn jokerGrob makeContent.joker_card_side jokerCardGrobFn makeContent.card_side cardGrobFn xya_pips_dominoes xya_pips_cards
#' @importFrom tibble tibble
xya_pips_cards <- function(n_pips) {
if (n_pips == 0) {
return(tibble(x = numeric(0), y = numeric(0), angle = numeric(0)))
}
switch(n_pips,
tibble(x = 0.5, y = 0.5, angle = 0), # 1
tibble(x = 0.5, y = c(0.2, 0.8), angle = c(180, 0)), # 2
tibble(x = 0.5, y = c(0.2, 0.5, 0.8), angle = c(180, 0, 0)), # 3
tibble(x = rep(c(0.25, 0.75), 2),
y = rep(c(0.2, 0.8), each=2), # 4
angle = rep(c(180, 0), each=2)),
tibble(x = c(rep(c(0.25, 0.75), 2), 0.5), # 5
y = c(rep(c(0.2, 0.8), each=2), 0.5),
angle = c(rep(180, 2), rep(0, 3))),
tibble(x = rep(c(0.25, 0.75), 3),
y = rep(c(0.2, 0.5, 0.8), each=2), # 6
angle = c(rep(180, 2), rep(0, 4))),
tibble(x = c(rep(c(0.25, 0.75), 3), 0.5), # 7
y = c(rep(c(0.2, 0.5, 0.75), each=2), 0.55),
angle = c(rep(180, 2), rep(0, 5))),
tibble(x = rep(c(0.25, 0.75), 4), # 8
y = rep(c(0.2, 0.4, 0.6, 0.8), each=2),
angle = c(rep(180, 4), rep(0, 4))),
tibble(x = c(rep(c(0.25, 0.75), 4), 0.5), # 9
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.7),
angle = c(rep(180, 4), rep(0, 5))),
tibble(x = c(0.5, rep(c(0.25, 0.75), 4), 0.5), # 10
y = c(0.3, rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.7),
angle = c(rep(180, 5), rep(0, 5))),
abort(paste0("Don't know pip pattern for ", n_pips, " pips"))
)
}
xya_pips_dominoes <- function(n_pips, die = FALSE, chinese = FALSE, other_pips = NULL) {
if (n_pips == 0) {
return(tibble(x = numeric(0), y = numeric(0), angle = numeric(0)))
}
if (die && !chinese) {
high <- 0.75
} else if (chinese && die) {
if (n_pips == 4) {
high <- 0.65
} else if (n_pips == 6) {
high <- 0.75
} else {
high <- 0.68
}
} else {
high <- 0.78
}
low <- 1 - high
if (chinese && !die) {
low <- 0.2
if (n_pips == 3 && other_pips < 5) {
high <- 1.0
} else if (n_pips == 4 && other_pips == 4) {
high <- 0.75
} else {
high <- 0.84
}
}
if (chinese && die && n_pips == 6) {
left <- 0.36
} else if (chinese && !die) {
left <- 0.30
} else {
left <- low
}
right <- 1 - left
mid <- 0.5 * (high + low)
switch(n_pips,
if (chinese && !die)
tibble(x = 0.5, y = low, angle = 0)
else
tibble(x = 0.5, y = mid, angle = 0), # 1
if (chinese)
if (die)
tibble(x = 0.5, y = c(low, high), angle = c(0, 180))
else
tibble(x = c(left, right), y = low, angle = c(0, 180))
else
tibble(x = c(left, right), y = c(high, low), angle = c(0, 180)), # 2
tibble(x = c(left, 0.5, right),
y = c(high, mid, low),
angle = c(0, 0, 180)), # 3
if (chinese && !die && other_pips != 4)
tibble(x = rep(c(left, right), 2), # 4
y = rep(c(low, mid), each=2),
angle = rep(c(180, 0), each=2))
else
tibble(x = rep(c(left, right), 2), # 4
y = rep(c(low, high), each=2),
angle = rep(c(180, 0), each=2)),
tibble(x = c(rep(c(left, right), 2), 0.5), # 5
y = c(rep(c(low, high), each=2), mid),
angle = c(rep(180, 2), rep(0, 3))),
tibble(x = rep(c(left, right), 3),
y = rep(c(low, mid, high), each=2), # 6
angle = c(rep(180, 2), rep(0, 4))),
tibble(x = c(rep(c(left, right), 3), 0.5), # 7
y = c(rep(c(low, 0.5, high), each=2), 0.50),
angle = c(rep(180, 2), rep(0, 5))),
tibble(x = c(0.5, rep(c(left, right), 3), 0.5), # 8
y = c(low, rep(c(low, 0.5, high), each=2), high),
angle = c(rep(180, 3), rep(0, 5))),
tibble(x = c(rep(c(left, 0.5, right), 3)), # 9
y = c(rep(c(low, 0.5, high), each=3)),
angle = c(rep(180, 3), rep(0, 6))),
tibble(x = c(0.5, rep(c(0.20, 0.80), 4), 0.5), # 10
y = c(0.2, rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.8),
angle = c(rep(180, 5), rep(0, 5))),
tibble(x = c(0.5, rep(c(0.20, 0.80), 4), 0.5, 0.5), # 11
y = c(0.2, rep(c(0.2, 0.4, 0.6, 0.8), each=2), 0.5, 0.8),
angle = c(rep(180, 5), rep(0, 6))),
tibble(x = c(rep(c(0.20, 0.5, 0.80), 4)), # 12
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=3)),
angle = c(rep(180, 6), rep(0, 6))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 3), 0.5), # 13
y = c(rep(c(0.2, 0.4, 0.6), each=4), 0.8),
angle = c(rep(180, 8), rep(0, 5))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 3), 0.3, 0.7), # 14
y = c(rep(c(0.2, 0.4, 0.6), each=4), 0.8, 0.8),
angle = c(rep(180, 8), rep(0, 6))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 3), 0.3, 0.5, 0.7), # 15
y = c(rep(c(0.2, 0.4, 0.6), each=4), 0.8, 0.8, 0.8),
angle = c(rep(180, 8), rep(0, 7))),
tibble(x = c(rep(c(0.2, 0.4, 0.6, 0.8), 4)), # 16
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=4)),
angle = c(rep(180, 8), rep(0, 8))),
tibble(x = c(rep(c(0.140, 0.340, 0.660, 0.860), 4), 0.5), # 17
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=4), 0.5),
angle = c(rep(180, 8), rep(0, 9))),
tibble(x = c(rep(c(0.140, 0.340, 0.660, 0.860), 4), 0.5, 0.5), # 18
y = c(rep(c(0.2, 0.4, 0.6, 0.8), each=4), 0.3, 0.7),
angle = c(rep(180, 8), rep(0, 8), 180, 0)),
abort(paste0("Don't know pip pattern for ", n_pips, " pips"))
)
}
cardGrobFn <- function(rank_offset = 0, type = "card", grob_type = "text") {
force(type)
force(rank_offset)
force(grob_type)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt=opt,
piece_side=piece_side, suit=suit, rank=rank, cfg=cfg,
type=type, rank_offset=rank_offset, grob_type=grob_type,
scale=1, border=TRUE,
cl=c("card_side", "basic_piece_side"))
}
}
#' @export
makeContent.card_side <- function(x) {
opt <- x$opt
type <- x$type
rank_offset <- x$rank_offset
grob_type <- x$grob_type
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name = "background")
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
gp_rank <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8)
rank_grob <- textGrob(label = opt$ps_text, gp = gp_rank,
x = c(0.1, 0.9), y = c(0.9, 0.1), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "rank")
gp_suit <- gpar(col = opt$dm_color, fontsize = opt$dm_fontsize,
fontfamily = opt$dm_fontfamily, fontface = opt$dm_fontface)
suit_grob <- textGrob(label = opt$dm_text, gp = gp_suit,
x = c(0.1, 0.9), y = c(0.8, 0.2), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "suit")
# Pips
tfn <- pippedGrobFn(rank_offset, type, grob_type, border = FALSE, mat = FALSE)
pip_grob <- tfn(x$piece_side, x$suit, x$rank, x$cfg)
pip_grob <- grid::editGrob(pip_grob,
vp=viewport(height = 1.0, width = 0.80, gp=gpar(cex=1.8)), name = "pips")
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name = "border")
} else {
border_grob <- nullGrob(name = "border")
}
gl <- gList(background_grob, pip_grob, rank_grob, suit_grob, mat_grob, border_grob)
setChildren(x, gl)
}
jokerCardGrobFn <- function(star = TRUE) {
force(star)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt = opt, star = star,
scale = 1, border = TRUE,
cl=c("joker_card_side", "basic_piece_side"))
}
}
#' @export
makeContent.joker_card_side <- function(x) {
opt <- x$opt
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name = "background")
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
gp_rank <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8)
rank_grob <- textGrob(label = opt$ps_text, gp = gp_rank,
x = c(0.1, 0.9), y = c(0.9, 0.1), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "rank")
# Joker
joker_grob <- jokerGrob(opt, x$star)
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name = "border")
} else {
border_grob <- nullGrob(name = "border")
}
gl <- gList(background_grob, joker_grob, rank_grob, mat_grob, border_grob)
setChildren(x, gl)
}
jokerGrob <- function(opt, star = TRUE) {
gp_meeple <- gpar(col = opt$ps_color, lwd = 4)
vp_meeple <- viewport(height=inch(1.3), width=inch(1.2), y = 0.4)
meeple_grob <- pp_shape("meeple")$shape(gp=gp_meeple, vp=vp_meeple)
gp_triangle <- gpar(fill = opt$ps_color, col = NA_character_)
y_triangle <- unit(0.4, "npc") + inch(0.5 * 1.3) + inch(0.5 * 0.8) + inch(-0.10)
vp_triangle <- viewport(height=inch(0.8), width=inch(0.45), y = y_triangle)
triangle_grob <- pp_shape("pyramid")$shape(gp=gp_triangle, vp=vp_triangle)
y_circle <- y_triangle + inch(0.5 * 0.8) + inch(0.5 * 0.2) + inch(-0.02)
vp_circle <- viewport(height=inch(0.2), width=inch(0.2), y = y_circle)
circle_grob <- circleGrob(vp = vp_circle, gp = gpar(col = opt$ps_color, lwd = 4))
if (star) {
star_grob <- pp_shape("concave5")$shape(gp = gp_triangle, vp = vp_circle)
} else {
star_grob <- NULL
}
grobTree(meeple_grob, triangle_grob, circle_grob, star_grob,
vp = viewport(width=0.8, height=0.9), cl = "joker")
}
faceCardGrobFn <- function(label = "", placement = "high") {
force(label)
force(placement)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt=opt, label=label, placement=placement,
scale=scale, border=TRUE,
cl=c("face_card_side", "basic_piece_side"))
}
}
#' @export
makeContent.face_card_side <- function(x) {
opt <- x$opt
label <- x$label
placement <- x$placement
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name = "background")
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
gp_rank <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8)
rank_grob <- textGrob(label = opt$ps_text, gp = gp_rank,
x = c(0.1, 0.9), y = c(0.9, 0.1), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "rank")
gp_suit <- gpar(col = opt$dm_color, fontsize = opt$dm_fontsize,
fontfamily = opt$dm_fontfamily, fontface = opt$dm_fontface)
suit_grob <- textGrob(label = opt$dm_text, gp = gp_suit,
x = c(0.1, 0.9), y = c(0.8, 0.2), rot = c(0, 180),
hjust = 0.5, vjust = 0.5, name = "suit")
# Face
top_grob <- faceGrob(opt, label, placement)
top_grob <- grid::editGrob(top_grob,
vp=viewport(y=0.75, height = 0.5, width = 0.80), name = "top")
bot_grob <- faceGrob(opt, label, placement)
bot_grob <- grid::editGrob(top_grob,
vp=viewport(y=0.25, height = 0.5, width = 0.80, angle = 180), name = "bottom")
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name = "border")
} else {
border_grob <- nullGrob(name = "border")
}
gl <- gList(background_grob, top_grob, bot_grob, rank_grob,
suit_grob, mat_grob, border_grob)
setChildren(x, gl)
}
faceGrob <- function(opt, label = "", placement = "high") {
if (placement == "high") {
y <- 0.7
x_meeple <- 0.5
y_meeple <- 0.3
in_meeple <- 1
cex <- 1.5
} else {
y <- 0.25
x_meeple <- 0.57
y_meeple <- 0.42
in_meeple <- 0.6
cex <- 3.0
}
rot <- ifelse(label %in% c("\u046a", "\u050a"), 180, 0)
gp_label <- gpar(col = opt$ps_color, fontsize = opt$ps_fontsize,
fontfamily = opt$ps_fontfamily, fontface = opt$ps_fontface,
lineheight = 0.8, cex = cex)
label_grob <- textGrob(label = label, gp = gp_label, x = 0.5, y = y,
hjust = 0.5, vjust = 0.5, rot = rot, name = "label")
gp_suit <- gpar(col = opt$dm_color, fontsize = opt$dm_fontsize,
fontfamily = opt$dm_fontfamily, fontface = opt$dm_fontface,
cex = in_meeple)
suit_grob <- textGrob(label = opt$dm_text, gp = gp_suit, x = x_meeple, y = y_meeple,
hjust = 0.5, vjust = 0.5, name = "suit")
gp_meeple <- gpar(col = opt$ps_color, lwd = 4)
vp_meeple <- viewport(height=inch(in_meeple), width=inch(in_meeple), x = x_meeple, y = y_meeple)
meeple_grob <- pp_shape("meeple")$shape(gp = gp_meeple, vp = vp_meeple)
grobTree(meeple_grob, label_grob, suit_grob, cl="face")
}
dominoGrobFn <- function(rank_offset = 0, type = "domino", grob_type = "circle") {
force(rank_offset)
force(type)
force(grob_type)
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt=opt, cfg=cfg, suit=suit, rank=rank,
type=type, rank_offset=rank_offset, grob_type=grob_type,
scale=1, border=TRUE,
cl=c("domino_side", "basic_piece_side"))
}
}
#' @export
makeContent.domino_side <- function(x) {
opt <- x$opt
suit <- x$suit
rank <- x$rank
type <- x$type
rank_offset <- x$rank_offset
grob_type <- x$grob_type
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
if (type == "domino_chinese")
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name="background")
else
background_grob <- NULL
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
# Top (Rank)
tfn <- pippedGrobFn(rank_offset, type, grob_type, border = FALSE, mat = FALSE,
background = !(type == "domino_chinese"),
other_pips = suit)
top_grob <- tfn("tile_face", rank, rank, x$cfg)
top_grob <- grid::editGrob(top_grob,
vp=viewport(height = 0.5, y = 0.75, angle = 180), name="top_rank")
# Bottom (Suit)
bfn <- pippedGrobFn(rank_offset, type, grob_type, border = FALSE, mat = FALSE,
background = !(type == "domino_chinese"),
other_pips = rank)
bot_grob <- bfn("tile_face", suit, suit, x$cfg)
bot_grob <- grid::editGrob(bot_grob,
vp=viewport(height = 0.5, y = 0.25), name="bottom_suit")
gp_gl <- gpar(col = opt$gridline_color, lex = opt$gridline_lex)
gl_grob <- segmentsGrob(x0=0.1, x1=0.9, y0 = 0.5, y1 = 0.5, gp=gp_gl, name="gridlines")
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name="border")
} else {
border_grob <- nullGrob(name="border")
}
gl <- gList(background_grob, top_grob, bot_grob, gl_grob, mat_grob, border_grob)
setChildren(x, gl)
}
pippedGrobFn <- function(rank_offset = 0, type = "die", grob_type = "circle",
border = TRUE, mat = TRUE, background = TRUE,
other_pips = NULL) {
function(piece_side, suit, rank, cfg=pp_cfg()) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gTree(opt = opt, n_pips = rank + rank_offset, type = type, grob_type = grob_type,
border = border, mat = mat, background = background,
other_pips = other_pips + rank_offset,
name = NULL, gp = gpar(), vp = NULL, cl = "pipped")
}
}
#' @export
makeContent.pipped <- function(x) {
opt <- x$opt
if (x$type == "card") {
xya <- xya_pips_cards(x$n_pips)
} else if (x$type == "die") {
xya <- xya_pips_dominoes(x$n_pips, die = TRUE)
} else if (x$type == "die_chinese") {
xya <- xya_pips_dominoes(x$n_pips, die = TRUE, chinese = TRUE)
} else if (x$type == "domino_chinese") {
xya <- xya_pips_dominoes(x$n_pips, die = FALSE, chinese = TRUE,
other_pips = x$other_pips)
} else {
xya <- xya_pips_dominoes(x$n_pips)
}
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
# Background
if (x$background) {
background_grob <- shape$shape(gp=gpar(col=NA, fill=opt$background_color), name="background")
} else {
background_grob <- NULL
}
# Mat
if (x$mat) {
gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")
} else {
mat_grob <- NULL
}
# Pips
if (nrow(xya) > 0) {
if (x$grob_type == "circle") {
if (x$type == "die_chinese" && (x$n_pips == 1 || x$n_pips == 4)) {
pip_color <- "#D55E00" # or just use "red"?
} else if (x$type == "domino_chinese" && (x$n_pips == 1 || x$n_pips == 4)) {
pip_color <- "#D55E00" # or just use "red"?
} else if (x$type == "domino_chinese" && x$n_pips == 6 && x$other_pips == 6) {
pip_color <- rep(c(opt$dm_color, "#D55E00"), 3L)
} else {
pip_color <- opt$dm_color
}
gp_pip <- gpar(col=pip_color, fill=pip_color)
if (x$type != "card" && x$n_pips > 9) {
r <- 0.06
} else if (x$type == "die_chinese") {
if (x$n_pips == 1) {
r <- 0.20
} else if (x$n_pips == 2) {
r <- 0.10
} else {
r <- 0.10
}
} else if (x$type == "domino_chinese") {
r <- 0.16
} else {
r <- 0.08
}
pip_grob <- circleGrob(x=xya$x, y=xya$y, r=r, gp=gp_pip, name="pips")
} else {
gp_pip <- gpar(col=opt$dm_color, fontsize=opt$dm_fontsize,
fontfamily=opt$dm_fontfamily, fontface=opt$dm_fontface)
pip_grob <- textGrob(opt$dm_text, x=xya$x, y=xya$y, rot = xya$angle,
gp = gp_pip, hjust = 0.5, vjust = 0.5, name="pips")
}
} else {
pip_grob <- nullGrob(name="pips")
}
# Border
if (x$border) {
gp_border <- gpar(col=opt$border_color, fill=NA, lex=opt$border_lex)
border_grob <- shape$shape(gp=gp_border, name="border")
} else {
border_grob <- NULL
}
gl <- gList(background_grob, mat_grob, pip_grob, border_grob)
setChildren(x, gl)
}
Try the piecepackr package in your browser
Any scripts or data that you put into this service are public.
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.