Nothing
R/utils-op-grobs.R
In piecepackr: Board Game Graphics
Defines functions
xy_vp_ps
makeContent.projected_pyramid_side
ps_grobcoords_xyl
basicPyramidSide
makeContent.projected_pyramid_top
pt_grobcoords_xyl
basicPyramidTop
ellipse_xyz
basicEllipsoid
basicDieEdge
die_grobcoords_xyl
makeContent.basic_projected_die
grobCoords.coords_xyl
basicDieGrob
grobCoords.general_projected_token
makeContent.general_projected_token
generalTokenGrob
basicTokenEdge
grobCoords.basic_projected_token
makeContent.basic_projected_token
basicTokenGrob
op_xy
op_xy <- function(x, y, z, op_angle=45, op_scale=0) {
x <- x + op_scale * z * cos(to_radians(op_angle))
y <- y + op_scale * z * sin(to_radians(op_angle))
list(x=x, y=y)
}
## Two-sided token
basicTokenGrob <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
side <- get_side(piece_side)
if (side %in% c("face", "back")) {
grob <- cfg$get_grob(piece_side, suit, rank, type)
xy_p <- op_xy(x, y, z+0.5*depth, op_angle, op_scale)
cvp <- viewport(xy_p$x, xy_p$y, width, height, angle=angle)
grob <- grid::editGrob(grob, name="piece_side", vp=cvp)
edge <- basicTokenEdge(piece_side, suit, rank, cfg,
x, y, z, angle, width, height, depth,
op_scale, op_angle)
edge <- grid::editGrob(edge, name="other_faces")
gl <- gList(edge, grob)
gTree(scale = 1, type = type,
children = gl, cl="basic_projected_token")
} else {
generalTokenGrob(piece_side, suit, rank, cfg,
x, y, z,
angle, type,
width, height, depth,
op_scale, op_angle)
}
}
#' @export
makeContent.basic_projected_token <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
x$children$other_faces <- update_gp(x$children$other_faces, gp)
if (hasName(x$children$piece_side, "scale"))
x$children$piece_side$scale <- x$scale
else if (x$type == "normal")
x$children$piece_side <- update_gp(x$children$piece_side, gp)
x
}
#' @export
grobCoords.basic_projected_token <- function(x, closed, ...) {
if (is.null(x$children$other_faces$coords_xyl))
NextMethod()
else
xylists_to_grobcoords(x$children$other_faces$coords_xyl, x$name, closed)
}
## Token edge-side grobs
basicTokenEdge <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
piece <- get_piece(piece_side)
side <- ifelse(opt$back, "back", "face") #### allow limited 3D rotation #281
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
R <- side_R(side) %*% AA_to_R(angle, axis_x = 0, axis_y = 0)
whd <- get_scaling_factors(side, width, height, depth)
pc <- Point3D$new(x, y, z)
token <- Token2S$new(shape, whd, pc, R)
gl <- gList()
# opposite side
#### Could use transformation grob (flipped)
opp_side <- ifelse(opt$back, "face", "back")
opp_piece_side <- paste0(piece, "_", opp_side)
opp_opt <- cfg$get_piece_opt(opp_piece_side, suit, rank)
gp_opp <- gpar(col=opp_opt$border_color, fill=opp_opt$background_color, lex=opp_opt$border_lex)
xyz_opp <- if (opt$back) token$xyz_face else token$xyz_back
xy_opp <- xyz_opp$project_op(op_angle, op_scale)
grob_opposite <- polygonGrob(x = xy_opp$x, y = xy_opp$y, default.units = "in",
gp = gp_opp, name="opposite_piece_side")
# edges
edges <- token$op_edges(op_angle)
for (i in seq_along(edges)) {
name <- paste0("edge", i)
gl[[i]] <- edges[[i]]$op_grob(op_angle, op_scale, name=name)
}
gp_edge <- gpar(col=opt$border_color, fill=opt$edge_color, lex=opt$border_lex)
grob_edge <- gTree(children=gl, gp=gp_edge, name="token_edges")
# pre-compute grobCoords
if (shape$convex)
coords_xyl <- as.list(as.data.frame(token$xyz$project_op(op_angle, op_scale)$convex_hull))
else
coords_xyl <- NULL
gTree(coords_xyl = coords_xyl,
children = gList(grob_opposite, grob_edge))
}
generalTokenGrob <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
piece <- get_piece(piece_side)
side <- get_side(piece_side)
opt <- cfg$get_piece_opt(paste0(piece, "_face"), suit, rank)
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
#### Generalize axis_x, axis_y #281
axis_x <- 0
axis_y <- 0
# geometric vertices
R <- side_R(side) %*% AA_to_R(angle, axis_x, axis_y)
whd <- get_scaling_factors(side, width, height, depth)
pc <- Point3D$new(x, y, z)
token <- Token2S$new(shape, whd, pc, R)
gl <- gList()
edges <- token$op_edges(op_angle)
for (i in seq_along(edges)) {
name <- paste0("edge", i)
gl[[i]] <- edges[[i]]$op_grob(op_angle, op_scale, name=name)
}
gp_edge <- gpar(col=opt$border_color, fill=opt$edge_color, lex=opt$border_lex)
grob_edge <- gTree(children=gl, gp=gp_edge, name="token_edges")
side_visible <- token$visible_side(op_angle)
piece_side <- paste0(piece, "_", side_visible)
xy_vp <- token$op_xy_vp(op_angle, op_scale, side_visible)
xy_polygon <- token$xyz_side(side_visible)$project_op(op_angle, op_scale)
ps_grob <- at_ps_grob(piece_side, suit, rank, cfg, xy_vp, xy_polygon)
gl <- gList(grob_edge, ps_grob)
# pre-compute grobCoords
if (shape$convex)
coords_xyl <- as.list(as.data.frame(token$xyz$project_op(op_angle, op_scale)$convex_hull))
else
coords_xyl <- NULL
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children = gl, cl = "general_projected_token")
}
#' @export
makeContent.general_projected_token <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
x$children$token_edges <- update_gp(x$children$token_edges, gp)
x$children$piece_side$scale <- x$scale
x
}
#' @export
grobCoords.general_projected_token <- function(x, closed, ...) {
if (is.null(x$coords_xyl))
NextMethod()
else
xylists_to_grobcoords(x$coords_xyl, x$name, closed)
}
## Die
basicDieGrob <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
grob <- cfg$get_grob(piece_side, suit, rank, type)
xy_p <- op_xy(x, y, z+0.5*depth, op_angle, op_scale)
cvp <- viewport(xy_p$x, xy_p$y, width, height, angle=angle)
grob <- grid::editGrob(grob, name="top_face", vp=cvp)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
#### allow limited 3D rotation #281
axis_x <- 0
axis_y <- 0
edge <- basicDieEdge(piece_side, suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
edge <- grid::editGrob(edge, name="other_faces")
gl <- gList(edge, grob)
# pre-compute grobCoords
coords_xyl <- die_grobcoords_xyl(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children = gl, cl=c("basic_projected_die", "coords_xyl"))
}
#' @export
grobCoords.coords_xyl <- function(x, closed, ...) {
xylists_to_grobcoords(x$coords_xyl, x$name, closed)
}
#' @export
makeContent.basic_projected_die <- function(x) {
x$children$other_faces$children[[1]]$scale <- x$scale
x$children$other_faces$children[[2]]$scale <- x$scale
if (hasName(x$children$top_face, "scale")) {
x$children$top_face$scale <- x$scale
} else if (x$type == "normal") {
gp <- gpar(cex = x$scale, lex = x$scale)
x$children$top_face <- update_gp(x$children$top_face, gp)
}
x
}
#### What if shape is "roundrect"?
die_grobcoords_xyl <- function(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle) {
xyz <- die_xyz(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth)
as.list(as.data.frame(xyz$project_op(op_angle, op_scale)$convex_hull))
}
basicDieEdge <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, axis_x=0, axis_y=0,
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
lf <- get_die_faces(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth)
gl <- gList()
indices_visible <- visible_die_faces(lf, op_angle)
#### For "round" dice add a grob for corners #298
for (i in indices_visible) {
xy <- lf$f_xyz[[i]]$project_op(op_angle, op_scale)
#### For "round" dice figure out coordinates for border lines #298
rank <- lf$die_face_info$rank[i]
name <- paste0("die_side", i)
gl[[i]] <- at_ps_grob(piece_side, suit, rank, cfg, xy, xy, name = name)
}
gTree(children=gl, name="die_sides", cl="basic_projected_die_edge")
}
## Ellipsoid
basicEllipsoid <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
xyz <- ellipse_xyz()$dilate(width, height, depth)$translate(x, y, z)
xy <- xyz$project_op(op_angle, op_scale)
xy_hull <- xy$convex_hull
gp <- gpar(col=opt$border_color, fill=opt$background_color, lex=opt$border_lex)
polygonGrob(x = xy_hull$x, y = xy_hull$y,
default.units = "in", gp = gp)
}
ellipse_xyz <- function() {
xy <- expand.grid(x=seq(0.0, 1.0, 0.05), y = seq(0.0, 1.0, 0.05))
xy <- xy[which(xy$x^2 + xy$y^2 <= 1), ]
z <- sqrt(1 - xy$x^2 - xy$y^2)
ppp <- data.frame(x=xy$x, y=xy$y, z=z)
ppn <- data.frame(x=xy$x, y=xy$y, z=-z)
pnp <- data.frame(x=xy$x, y=-xy$y, z=z)
pnn <- data.frame(x=xy$x, y=-xy$y, z=-z)
nnp <- data.frame(x=-xy$x, y=-xy$y, z=z)
npp <- data.frame(x=-xy$x, y=xy$y, z=z)
npn <- data.frame(x=-xy$x, y=xy$y, z=-z)
nnn <- data.frame(x=-xy$x, y=-xy$y, z=-z)
df <- 0.5 * rbind(ppp, ppn, pnp, pnn, nnp, npp, npn, nnn)
Point3D$new(df)
}
## Pyramid Top
basicPyramidTop <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
xy <- Point2D$new(x, y)
xy_b <- Point2D$new(rect_xy)$npc_to_in(x, y, width, height, angle)
p <- Polygon$new(xy_b)
edge_types <- paste0("pyramid_", c("left", "back", "right", "face"))
order <- p$op_edge_order(op_angle)
df <- tibble(index = 1:4, edge = edge_types)[order, ]
gl <- gList()
for (i in 1:4) {
opt <- cfg$get_piece_opt(df$edge[i], suit, rank)
gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
edge <- p$edges[df$index[i]]
ex <- c(x, edge$p1$x, edge$p2$x)
ey <- c(y, edge$p1$y, edge$p2$y)
ez <- c(z + 0.5 * depth, z - 0.5 * depth, z - 0.5 * depth)
xyz_polygon <- Point3D$new(x = ex, y = ey, z = ez)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
piece_side <- df$edge[i]
gl[[i]] <- at_ps_grob(piece_side, suit, rank, cfg, xy_vp, xy_polygon, name = piece_side)
}
#### allow limited 3D rotation #281
axis_x <- 0
axis_y <- 0
# pre-compute grobCoords
coords_xyl <- pt_grobcoords_xyl(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children=gl, cl=c("projected_pyramid_top", "coords_xyl"))
}
pt_grobcoords_xyl <- function(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle) {
xyz <- pt_xyz(x, y, z,
angle, axis_x, axis_y,
width, height, depth)
as.list(as.data.frame(xyz$project_op(op_angle, op_scale)$convex_hull))
}
#' @export
makeContent.projected_pyramid_top <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
for (i in 1:4) {
if (hasName(x$children[[i]], "scale"))
x$children[[i]]$scale <- x$scale
else if (x$type == "normal")
x$children[[i]] <- update_gp(x$children[[i]], gp)
}
x
}
## Pyramid side
basicPyramidSide <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
xy_b <- Point2D$new(pyramid_xy)$npc_to_in(x, y, width, height, angle)
p <- Polygon$new(xy_b)
xy_tip <- xy_b[1]
theta <- 2 * asin(0.5 * width / height)
yt <- 1 - cos(theta)
xy_t <- Point2D$new(x = 0:1, y = yt)$npc_to_in(x, y, width, height, angle)
gl <- gList()
## opposite edge
opposite_edge <- switch(piece_side,
"pyramid_face" = "pyramid_back",
"pyramid_back" = "pyramid_face",
"pyramid_left" = "pyramid_right",
"pyramid_right" = "pyramid_left")
xyz_polygon <- Point3D$new(x = xy_b$x[c(1, 3:2)],
y = xy_b$y[c(1, 3:2)],
z = z - 0.5 * depth)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
gl[[1]] <- at_ps_grob(opposite_edge, suit, rank, cfg, xy_vp, xy_polygon,
name = opposite_edge)
## side edges
edge_types <- paste0("pyramid_", switch(piece_side,
"pyramid_face" = c("right", "bottom", "left"),
"pyramid_left" = c("face", "bottom", "back"),
"pyramid_back" = c("left", "bottom", "right"),
"pyramid_right" = c("back", "bottom", "face")
))
order <- p$op_edge_order(op_angle)
df <- tibble(index = 1:3, edge = edge_types)[order, ]
gli <- 2
for (i in 1:3) {
edge_ps <- df$edge[i]
index <- df$index[i]
if (edge_ps == "pyramid_bottom") next
opt <- cfg$get_piece_opt(edge_ps, suit, rank)
gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
edge <- p$edges[index]
if (index == 1) { # right side viewed top (left side viewed on side)
ex <- c(edge$p1$x, edge$p2$x, xy_t$x[1])
ey <- c(edge$p1$y, edge$p2$y, xy_t$y[1])
ez <- c(z - 0.5 * depth, z - 0.5 * depth, z + 0.5 * depth)
} else { # left side viewed top (right side viewed on side)
ex <- c(edge$p2$x, xy_t$x[2], edge$p1$x)
ey <- c(edge$p2$y, xy_t$y[2], edge$p1$y)
ez <- c(z - 0.5 * depth, z + 0.5 * depth, z - 0.5 * depth)
}
xyz_polygon <- Point3D$new(x = ex, y = ey, z = ez)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
gl[[gli]] <- at_ps_grob(edge_ps, suit, rank, cfg, xy_vp, xy_polygon, name = edge_ps)
gli <- gli + 1
}
## edge facing up
x_f <- c(xy_tip$x, xy_t$x)
y_f <- c(xy_tip$y, xy_t$y)
z_f <- c(z - 0.5 * depth, z + 0.5 * depth, z + 0.5 * depth)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
xyz_polygon <- Point3D$new(x = x_f, y = y_f, z = z_f)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
gl[[4]] <- at_ps_grob(piece_side, suit, rank, cfg, xy_vp, xy_polygon, name = piece_side)
#### allow limited 3D rotation #281
axis_x <- 0
axis_y <- 0
# pre-compute grobCoords
coords_xyl <- ps_grobcoords_xyl(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children=gl, cl=c("projected_pyramid_side", "coords_xyl"))
}
ps_grobcoords_xyl <- function(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle) {
xyz <- ps_xyz(x, y, z,
angle, axis_x, axis_y,
width, height, depth)
as.list(as.data.frame(xyz$project_op(op_angle, op_scale)$convex_hull))
}
#' @export
makeContent.projected_pyramid_side <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
for (i in 1:4) {
if (hasName(x$children[[i]], "scale"))
x$children[[i]]$scale <- x$scale
else if (x$type == "normal")
x$children[[i]] <- update_gp(x$children[[i]], gp)
}
x
}
# compute `xy_vp` for pyramid sides
xy_vp_ps <- function(xyz_polygon, op_scale, op_angle) {
p_midbottom <- xyz_polygon[2:3]$c
p_diff <- p_midbottom$diff(xyz_polygon[1])
p_ul <- xyz_polygon[2]$translate(p_diff)
p_ur <- xyz_polygon[3]$translate(p_diff)
x <- c(p_ul$x, xyz_polygon$x[2:3], p_ur$x)
y <- c(p_ul$y, xyz_polygon$y[2:3], p_ur$y)
z <- c(p_ul$z, xyz_polygon$z[2:3], p_ur$z)
Point3D$new(x, y, z)$project_op(op_angle, op_scale)
}
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 xy_vp_ps makeContent.projected_pyramid_side ps_grobcoords_xyl basicPyramidSide makeContent.projected_pyramid_top pt_grobcoords_xyl basicPyramidTop ellipse_xyz basicEllipsoid basicDieEdge die_grobcoords_xyl makeContent.basic_projected_die grobCoords.coords_xyl basicDieGrob grobCoords.general_projected_token makeContent.general_projected_token generalTokenGrob basicTokenEdge grobCoords.basic_projected_token makeContent.basic_projected_token basicTokenGrob op_xy
op_xy <- function(x, y, z, op_angle=45, op_scale=0) {
x <- x + op_scale * z * cos(to_radians(op_angle))
y <- y + op_scale * z * sin(to_radians(op_angle))
list(x=x, y=y)
}
## Two-sided token
basicTokenGrob <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
side <- get_side(piece_side)
if (side %in% c("face", "back")) {
grob <- cfg$get_grob(piece_side, suit, rank, type)
xy_p <- op_xy(x, y, z+0.5*depth, op_angle, op_scale)
cvp <- viewport(xy_p$x, xy_p$y, width, height, angle=angle)
grob <- grid::editGrob(grob, name="piece_side", vp=cvp)
edge <- basicTokenEdge(piece_side, suit, rank, cfg,
x, y, z, angle, width, height, depth,
op_scale, op_angle)
edge <- grid::editGrob(edge, name="other_faces")
gl <- gList(edge, grob)
gTree(scale = 1, type = type,
children = gl, cl="basic_projected_token")
} else {
generalTokenGrob(piece_side, suit, rank, cfg,
x, y, z,
angle, type,
width, height, depth,
op_scale, op_angle)
}
}
#' @export
makeContent.basic_projected_token <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
x$children$other_faces <- update_gp(x$children$other_faces, gp)
if (hasName(x$children$piece_side, "scale"))
x$children$piece_side$scale <- x$scale
else if (x$type == "normal")
x$children$piece_side <- update_gp(x$children$piece_side, gp)
x
}
#' @export
grobCoords.basic_projected_token <- function(x, closed, ...) {
if (is.null(x$children$other_faces$coords_xyl))
NextMethod()
else
xylists_to_grobcoords(x$children$other_faces$coords_xyl, x$name, closed)
}
## Token edge-side grobs
basicTokenEdge <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
piece <- get_piece(piece_side)
side <- ifelse(opt$back, "back", "face") #### allow limited 3D rotation #281
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
R <- side_R(side) %*% AA_to_R(angle, axis_x = 0, axis_y = 0)
whd <- get_scaling_factors(side, width, height, depth)
pc <- Point3D$new(x, y, z)
token <- Token2S$new(shape, whd, pc, R)
gl <- gList()
# opposite side
#### Could use transformation grob (flipped)
opp_side <- ifelse(opt$back, "face", "back")
opp_piece_side <- paste0(piece, "_", opp_side)
opp_opt <- cfg$get_piece_opt(opp_piece_side, suit, rank)
gp_opp <- gpar(col=opp_opt$border_color, fill=opp_opt$background_color, lex=opp_opt$border_lex)
xyz_opp <- if (opt$back) token$xyz_face else token$xyz_back
xy_opp <- xyz_opp$project_op(op_angle, op_scale)
grob_opposite <- polygonGrob(x = xy_opp$x, y = xy_opp$y, default.units = "in",
gp = gp_opp, name="opposite_piece_side")
# edges
edges <- token$op_edges(op_angle)
for (i in seq_along(edges)) {
name <- paste0("edge", i)
gl[[i]] <- edges[[i]]$op_grob(op_angle, op_scale, name=name)
}
gp_edge <- gpar(col=opt$border_color, fill=opt$edge_color, lex=opt$border_lex)
grob_edge <- gTree(children=gl, gp=gp_edge, name="token_edges")
# pre-compute grobCoords
if (shape$convex)
coords_xyl <- as.list(as.data.frame(token$xyz$project_op(op_angle, op_scale)$convex_hull))
else
coords_xyl <- NULL
gTree(coords_xyl = coords_xyl,
children = gList(grob_opposite, grob_edge))
}
generalTokenGrob <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
piece <- get_piece(piece_side)
side <- get_side(piece_side)
opt <- cfg$get_piece_opt(paste0(piece, "_face"), suit, rank)
shape <- pp_shape(opt$shape, opt$shape_t, opt$shape_r, opt$back)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
#### Generalize axis_x, axis_y #281
axis_x <- 0
axis_y <- 0
# geometric vertices
R <- side_R(side) %*% AA_to_R(angle, axis_x, axis_y)
whd <- get_scaling_factors(side, width, height, depth)
pc <- Point3D$new(x, y, z)
token <- Token2S$new(shape, whd, pc, R)
gl <- gList()
edges <- token$op_edges(op_angle)
for (i in seq_along(edges)) {
name <- paste0("edge", i)
gl[[i]] <- edges[[i]]$op_grob(op_angle, op_scale, name=name)
}
gp_edge <- gpar(col=opt$border_color, fill=opt$edge_color, lex=opt$border_lex)
grob_edge <- gTree(children=gl, gp=gp_edge, name="token_edges")
side_visible <- token$visible_side(op_angle)
piece_side <- paste0(piece, "_", side_visible)
xy_vp <- token$op_xy_vp(op_angle, op_scale, side_visible)
xy_polygon <- token$xyz_side(side_visible)$project_op(op_angle, op_scale)
ps_grob <- at_ps_grob(piece_side, suit, rank, cfg, xy_vp, xy_polygon)
gl <- gList(grob_edge, ps_grob)
# pre-compute grobCoords
if (shape$convex)
coords_xyl <- as.list(as.data.frame(token$xyz$project_op(op_angle, op_scale)$convex_hull))
else
coords_xyl <- NULL
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children = gl, cl = "general_projected_token")
}
#' @export
makeContent.general_projected_token <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
x$children$token_edges <- update_gp(x$children$token_edges, gp)
x$children$piece_side$scale <- x$scale
x
}
#' @export
grobCoords.general_projected_token <- function(x, closed, ...) {
if (is.null(x$coords_xyl))
NextMethod()
else
xylists_to_grobcoords(x$coords_xyl, x$name, closed)
}
## Die
basicDieGrob <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
grob <- cfg$get_grob(piece_side, suit, rank, type)
xy_p <- op_xy(x, y, z+0.5*depth, op_angle, op_scale)
cvp <- viewport(xy_p$x, xy_p$y, width, height, angle=angle)
grob <- grid::editGrob(grob, name="top_face", vp=cvp)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
#### allow limited 3D rotation #281
axis_x <- 0
axis_y <- 0
edge <- basicDieEdge(piece_side, suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
edge <- grid::editGrob(edge, name="other_faces")
gl <- gList(edge, grob)
# pre-compute grobCoords
coords_xyl <- die_grobcoords_xyl(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children = gl, cl=c("basic_projected_die", "coords_xyl"))
}
#' @export
grobCoords.coords_xyl <- function(x, closed, ...) {
xylists_to_grobcoords(x$coords_xyl, x$name, closed)
}
#' @export
makeContent.basic_projected_die <- function(x) {
x$children$other_faces$children[[1]]$scale <- x$scale
x$children$other_faces$children[[2]]$scale <- x$scale
if (hasName(x$children$top_face, "scale")) {
x$children$top_face$scale <- x$scale
} else if (x$type == "normal") {
gp <- gpar(cex = x$scale, lex = x$scale)
x$children$top_face <- update_gp(x$children$top_face, gp)
}
x
}
#### What if shape is "roundrect"?
die_grobcoords_xyl <- function(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle) {
xyz <- die_xyz(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth)
as.list(as.data.frame(xyz$project_op(op_angle, op_scale)$convex_hull))
}
basicDieEdge <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, axis_x=0, axis_y=0,
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
lf <- get_die_faces(suit, rank, cfg,
x, y, z,
angle, axis_x, axis_y,
width, height, depth)
gl <- gList()
indices_visible <- visible_die_faces(lf, op_angle)
#### For "round" dice add a grob for corners #298
for (i in indices_visible) {
xy <- lf$f_xyz[[i]]$project_op(op_angle, op_scale)
#### For "round" dice figure out coordinates for border lines #298
rank <- lf$die_face_info$rank[i]
name <- paste0("die_side", i)
gl[[i]] <- at_ps_grob(piece_side, suit, rank, cfg, xy, xy, name = name)
}
gTree(children=gl, name="die_sides", cl="basic_projected_die_edge")
}
## Ellipsoid
basicEllipsoid <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
xyz <- ellipse_xyz()$dilate(width, height, depth)$translate(x, y, z)
xy <- xyz$project_op(op_angle, op_scale)
xy_hull <- xy$convex_hull
gp <- gpar(col=opt$border_color, fill=opt$background_color, lex=opt$border_lex)
polygonGrob(x = xy_hull$x, y = xy_hull$y,
default.units = "in", gp = gp)
}
ellipse_xyz <- function() {
xy <- expand.grid(x=seq(0.0, 1.0, 0.05), y = seq(0.0, 1.0, 0.05))
xy <- xy[which(xy$x^2 + xy$y^2 <= 1), ]
z <- sqrt(1 - xy$x^2 - xy$y^2)
ppp <- data.frame(x=xy$x, y=xy$y, z=z)
ppn <- data.frame(x=xy$x, y=xy$y, z=-z)
pnp <- data.frame(x=xy$x, y=-xy$y, z=z)
pnn <- data.frame(x=xy$x, y=-xy$y, z=-z)
nnp <- data.frame(x=-xy$x, y=-xy$y, z=z)
npp <- data.frame(x=-xy$x, y=xy$y, z=z)
npn <- data.frame(x=-xy$x, y=xy$y, z=-z)
nnn <- data.frame(x=-xy$x, y=-xy$y, z=-z)
df <- 0.5 * rbind(ppp, ppn, pnp, pnn, nnp, npp, npn, nnn)
Point3D$new(df)
}
## Pyramid Top
basicPyramidTop <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
xy <- Point2D$new(x, y)
xy_b <- Point2D$new(rect_xy)$npc_to_in(x, y, width, height, angle)
p <- Polygon$new(xy_b)
edge_types <- paste0("pyramid_", c("left", "back", "right", "face"))
order <- p$op_edge_order(op_angle)
df <- tibble(index = 1:4, edge = edge_types)[order, ]
gl <- gList()
for (i in 1:4) {
opt <- cfg$get_piece_opt(df$edge[i], suit, rank)
gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
edge <- p$edges[df$index[i]]
ex <- c(x, edge$p1$x, edge$p2$x)
ey <- c(y, edge$p1$y, edge$p2$y)
ez <- c(z + 0.5 * depth, z - 0.5 * depth, z - 0.5 * depth)
xyz_polygon <- Point3D$new(x = ex, y = ey, z = ez)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
piece_side <- df$edge[i]
gl[[i]] <- at_ps_grob(piece_side, suit, rank, cfg, xy_vp, xy_polygon, name = piece_side)
}
#### allow limited 3D rotation #281
axis_x <- 0
axis_y <- 0
# pre-compute grobCoords
coords_xyl <- pt_grobcoords_xyl(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children=gl, cl=c("projected_pyramid_top", "coords_xyl"))
}
pt_grobcoords_xyl <- function(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle) {
xyz <- pt_xyz(x, y, z,
angle, axis_x, axis_y,
width, height, depth)
as.list(as.data.frame(xyz$project_op(op_angle, op_scale)$convex_hull))
}
#' @export
makeContent.projected_pyramid_top <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
for (i in 1:4) {
if (hasName(x$children[[i]], "scale"))
x$children[[i]]$scale <- x$scale
else if (x$type == "normal")
x$children[[i]] <- update_gp(x$children[[i]], gp)
}
x
}
## Pyramid side
basicPyramidSide <- function(piece_side, suit, rank, cfg=pp_cfg(),
x=unit(0.5, "npc"), y=unit(0.5, "npc"), z=unit(0, "npc"),
angle=0, type="normal",
width=NA, height=NA, depth=NA,
op_scale=0, op_angle=45) {
cfg <- as_pp_cfg(cfg)
x <- convertX(x, "in", valueOnly = TRUE)
y <- convertY(y, "in", valueOnly = TRUE)
z <- convertX(z, "in", valueOnly = TRUE)
width <- convertX(width, "in", valueOnly = TRUE)
height <- convertY(height, "in", valueOnly = TRUE)
depth <- convertX(depth, "in", valueOnly = TRUE)
xy_b <- Point2D$new(pyramid_xy)$npc_to_in(x, y, width, height, angle)
p <- Polygon$new(xy_b)
xy_tip <- xy_b[1]
theta <- 2 * asin(0.5 * width / height)
yt <- 1 - cos(theta)
xy_t <- Point2D$new(x = 0:1, y = yt)$npc_to_in(x, y, width, height, angle)
gl <- gList()
## opposite edge
opposite_edge <- switch(piece_side,
"pyramid_face" = "pyramid_back",
"pyramid_back" = "pyramid_face",
"pyramid_left" = "pyramid_right",
"pyramid_right" = "pyramid_left")
xyz_polygon <- Point3D$new(x = xy_b$x[c(1, 3:2)],
y = xy_b$y[c(1, 3:2)],
z = z - 0.5 * depth)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
gl[[1]] <- at_ps_grob(opposite_edge, suit, rank, cfg, xy_vp, xy_polygon,
name = opposite_edge)
## side edges
edge_types <- paste0("pyramid_", switch(piece_side,
"pyramid_face" = c("right", "bottom", "left"),
"pyramid_left" = c("face", "bottom", "back"),
"pyramid_back" = c("left", "bottom", "right"),
"pyramid_right" = c("back", "bottom", "face")
))
order <- p$op_edge_order(op_angle)
df <- tibble(index = 1:3, edge = edge_types)[order, ]
gli <- 2
for (i in 1:3) {
edge_ps <- df$edge[i]
index <- df$index[i]
if (edge_ps == "pyramid_bottom") next
opt <- cfg$get_piece_opt(edge_ps, suit, rank)
gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
edge <- p$edges[index]
if (index == 1) { # right side viewed top (left side viewed on side)
ex <- c(edge$p1$x, edge$p2$x, xy_t$x[1])
ey <- c(edge$p1$y, edge$p2$y, xy_t$y[1])
ez <- c(z - 0.5 * depth, z - 0.5 * depth, z + 0.5 * depth)
} else { # left side viewed top (right side viewed on side)
ex <- c(edge$p2$x, xy_t$x[2], edge$p1$x)
ey <- c(edge$p2$y, xy_t$y[2], edge$p1$y)
ez <- c(z - 0.5 * depth, z + 0.5 * depth, z - 0.5 * depth)
}
xyz_polygon <- Point3D$new(x = ex, y = ey, z = ez)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
gl[[gli]] <- at_ps_grob(edge_ps, suit, rank, cfg, xy_vp, xy_polygon, name = edge_ps)
gli <- gli + 1
}
## edge facing up
x_f <- c(xy_tip$x, xy_t$x)
y_f <- c(xy_tip$y, xy_t$y)
z_f <- c(z - 0.5 * depth, z + 0.5 * depth, z + 0.5 * depth)
opt <- cfg$get_piece_opt(piece_side, suit, rank)
gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
xyz_polygon <- Point3D$new(x = x_f, y = y_f, z = z_f)
xy_polygon <- xyz_polygon$project_op(op_angle, op_scale)
xy_vp <- xy_vp_ps(xyz_polygon, op_scale, op_angle)
gl[[4]] <- at_ps_grob(piece_side, suit, rank, cfg, xy_vp, xy_polygon, name = piece_side)
#### allow limited 3D rotation #281
axis_x <- 0
axis_y <- 0
# pre-compute grobCoords
coords_xyl <- ps_grobcoords_xyl(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle)
gTree(scale = 1, type = type,
coords_xyl = coords_xyl,
children=gl, cl=c("projected_pyramid_side", "coords_xyl"))
}
ps_grobcoords_xyl <- function(x, y, z,
angle, axis_x, axis_y,
width, height, depth,
op_scale, op_angle) {
xyz <- ps_xyz(x, y, z,
angle, axis_x, axis_y,
width, height, depth)
as.list(as.data.frame(xyz$project_op(op_angle, op_scale)$convex_hull))
}
#' @export
makeContent.projected_pyramid_side <- function(x) {
gp <- gpar(cex = x$scale, lex = x$scale)
for (i in 1:4) {
if (hasName(x$children[[i]], "scale"))
x$children[[i]]$scale <- x$scale
else if (x$type == "normal")
x$children[[i]] <- update_gp(x$children[[i]], gp)
}
x
}
# compute `xy_vp` for pyramid sides
xy_vp_ps <- function(xyz_polygon, op_scale, op_angle) {
p_midbottom <- xyz_polygon[2:3]$c
p_diff <- p_midbottom$diff(xyz_polygon[1])
p_ul <- xyz_polygon[2]$translate(p_diff)
p_ur <- xyz_polygon[3]$translate(p_diff)
x <- c(p_ul$x, xyz_polygon$x[2:3], p_ur$x)
y <- c(p_ul$y, xyz_polygon$y[2:3], p_ur$y)
z <- c(p_ul$z, xyz_polygon$z[2:3], p_ur$z)
Point3D$new(x, y, z)$project_op(op_angle, op_scale)
}
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.