Token2S <- R6Class("token2s",
public = list(initialize = function(shape = pp_shape(),
whd = list(width = 1, height = 1, depth = 1),
center = Point3D$new(),
R = diag(3)) {
# coordinates
xy_npc <- Point2D$new(shape$npc_coords)
xyz_scaled <- Point3D$new(xy_npc)$translate(-0.5, -0.5, 0.5)$dilate(whd)
xyz_f <- xyz_scaled$rotate(R)$translate(center)
xyz_scaled <- Point3D$new(xy_npc)$translate(-0.5, -0.5, -0.5)$dilate(whd)
xyz_b <- xyz_scaled$rotate(R)$translate(center)
self$xyz <- Point3D$new(x = c(xyz_f$x, xyz_b$x),
y = c(xyz_f$y, xyz_b$y),
z = c(xyz_f$z, xyz_b$z))
xy_vp <- Point2D$new(rect_xy)
xyz_scaled <- Point3D$new(xy_vp)$translate(-0.5, -0.5, 0.5)$dilate(whd)
self$xyz_vp_face <- xyz_scaled$rotate(R)$translate(center)
# Flip so back also in "upper_left", "lower_left", "lower_right", "upper_right" order
xy_vp <- Point2D$new(x = rect_xy$x[4:1], y = rect_xy$y[4:1])
xyz_scaled <- Point3D$new(xy_vp)$translate(-0.5, -0.5, -0.5)$dilate(whd)
self$xyz_vp_back <- xyz_scaled$rotate(R)$translate(center)
# edges
edge_partition <- partition_edges(shape)
n_points <- length(xyz_f)
n_edges <- length(edge_partition$type)
edges <- vector("list", n_edges)
for (i in seq(n_edges)) {
vertices <- self$xyz[edge_indices(edge_partition$indices[[i]], n_points)]
type <- edge_partition$type[i]
edges[[i]] <- edge_class(type, vertices)
}
self$edges <- edges
},
op_edge_order = function(angle) {
r <- 10 * self$xyz$width
op_ref <- Point2D$new(0, 0)$translate_polar(180 + angle, r)
op_line <- Line$new(angle, op_ref)
depths <- sapply(self$edges, function(x) x$vertices$c$z)
dists <- sapply(self$edges, function(x) op_line$distance_to(x$vertices$c))
order(round(depths, 6), -dists) # `round()` avoids weird sorting errors
},
op_edges = function(angle) {
self$edges[self$op_edge_order(angle)]
},
op_xy_vp = function(angle, scale, side) {
switch(side,
face = self$xyz_vp_face$project_op(angle, scale),
back = self$xyz_vp_back$project_op(angle, scale),
abort(paste("Can't handle side", side)))
},
#### Handle edge case for token (almost) parallel to xy-axis
visible_side = function(angle) {
r <- 10 * self$xyz$width
op_diff <- Point2D$new(0, 0)$translate_polar(angle, r)
op_ref <- Point2D$new(0, 0)$translate_polar(180 + angle, r)
op_line <- Line$new(angle, op_ref)
if (op_line$distance_to(self$xyz_face$c) <
op_line$distance_to(self$xyz_back$c))
"face"
else
"back"
},
xyz_side = function(side) {
switch(side,
face = self$xyz_face,
back = self$xyz_back)
},
xyz = NULL, edges = NULL,
xyz_vp_face = NULL, xyz_vp_back = NULL
),
private = list(),
active = list(xyz_face = function() {
n <- length(self$xyz$x) / 2
self$xyz[seq(n)]
},
xyz_back = function() {
n <- length(self$xyz$x) / 2
self$xyz[seq(n + 1, 2 * n)]
})
)
edge_indices <- function(indices, n_points) {
c(indices, n_points + rev(indices))
}
edge_class <- function(type, vertices) {
switch(type,
curved = CurvedEdge$new(vertices),
flat = FlatEdge$new(vertices),
ring = RingEdge$new(vertices))
}
partition_edges <- function(shape) {
classes <- shape$npc_coords$c
n <- length(classes)
if (all(classes == "C0")) {
list(type = rep("flat", n),
indices = lapply(seq_along(classes), function(x) c(x, x %% n + 1)))
} else if (all(classes == "C1")) {
list(type = "ring", indices = list(seq_along(classes)))
} else {
if (!(classes[n] == "C0")) abort("Can only handle case when last class is 'C0'")
type <- vector("character")
indices <- vector("list")
index <- 1
prev <- classes[n]
curve_start <- NULL
for (i in seq_along(classes)) {
class <- classes[i]
if (all(c(prev, class) == "C0")) {
type[index] <- "flat"
i_prev <- ifelse(i == 1, n, i - 1)
indices[[index]] <- c(i_prev, i)
index <- index + 1
} else if (prev == "C1" && class == "C0") { # end of curved
type[index] <- "curved"
if (curve_start == 0) {
indices[[index]] <- c(n, seq(i))
} else {
indices[[index]] <- seq(curve_start, i)
}
index <- index + 1
} else if (prev == "C0" && class == "C1") { # start of curved
curve_start <- i - 1
}
prev <- class
}
list(type = type, indices = indices)
}
}
Edge <- R6Class("edge",
public = list(vertices = NULL,
initialize = function(vertices = NULL) self$vertices <- vertices,
visible_side = function(angle) {
r <- 10 * self$vertices$width
op_diff <- Point2D$new(0, 0)$translate_polar(angle, r)
op_ref <- Point2D$new(0, 0)$translate_polar(180 + angle, r)
op_line <- Line$new(angle, op_ref)
if (op_line$distance_to(self$vertices_face$c) <
op_line$distance_to(self$vertices_back$c))
"face"
else
"back"
},
vertices_visible_side = function(angle) {
side <- self$visible_side(angle)
switch(side,
face = self$vertices_face,
back = self$vertices_back)
}),
private = list(),
active = list(
# won't work for "FlatEdge" but doesn't need to
is_perpendicular_xyplane = function() {
length(unique(round(self$vertices$z, 6))) == 2
},
vertices_face = function() {
n <- length(self$vertices$x) / 2
self$vertices[seq(n)]
},
vertices_back = function() {
n <- length(self$vertices$x) / 2
self$vertices[seq(n + 1, 2 * n)]
})
)
FlatEdge <- R6Class("edge_flat", inherit = Edge,
public = list(op_grob = function(angle, scale, name = NULL) {
xy <- self$vertices$project_op(angle, scale)
polygonGrob(xy$x, xy$y, default.units = "in", name = name)
}),
private = list(),
active = list()
)
## Convex, closed curved edge
RingEdge <- R6Class("edge_ring", inherit = Edge,
public = list(op_grob = function(angle, scale, name = NULL) {
if (self$is_perpendicular_xyplane) {
private$op_grob_perpendicular(angle, scale, name = name)
} else {
private$op_grob_nonperpendicular(angle, scale, name = name)
}
}),
private = list(
op_grob_nonperpendicular = function(angle, scale, name = NULL) {
xy <- self$vertices$project_op(angle, scale)
xyh <- xy$convex_hull
xy_visible <- self$vertices_visible_side(angle)$project_op(angle, scale)
xyh_visible <- xy_visible$convex_hull
A <- list(list(x = xyh$x, y = xyh$y))
B <- list(list(x = xyh_visible$x, y = xyh_visible$y))
xy_minus <- gridGeometry::polyclip(A, B, op = "minus")
#### also include obscured edge (i.e. A intersection B)?
gridGeometry::xyListPolygon(xy_minus, name = name)
},
op_grob_perpendicular = function(angle, scale, name = NULL) {
n <- length(self$vertices) / 2
xy_f <- self$vertices[seq(n)]$project_op(angle, scale)
projections <- numeric(n)
proj_vec <- Vector$new(to_x(angle - 90, 1), to_y(angle - 90, 1))
for (ii in seq(n)) {
projections[ii] <- proj_vec$dot(xy_f[ii])
}
i_min <- which.min(projections)
i_max <- which.max(projections)
if (i_min < i_max) {
indices1 <- seq(i_min, i_max)
if (i_max < n) {
indices2 <- c(seq(i_max + 1, n), seq_len(i_min - 1))
} else {
indices2 <- seq(1, i_min - 1)
}
} else {
indices1 <- c(seq(i_min, n), seq(1, i_max))
indices2 <- seq(i_max + 1, i_min - 1)
}
# figure out which part farthest
r <- 10 * self$vertices$width
op_diff <- Point2D$new(0, 0)$translate_polar(angle, r)
op_diff <- Point3D$new(op_diff, z = r / sqrt(2))
op_ref <- self$vertices$c$translate(op_diff)
d1 <- op_ref$distance_to(self$vertices[indices1]$c)
d2 <- op_ref$distance_to(self$vertices[indices2]$c)
if (d1 > d2) {
indices_obscured <- indices2
indices_visible <- indices1
} else {
indices_obscured <- indices1
indices_visible <- indices2
}
xy <- self$vertices$project_op(angle, scale)
x_obscured <- xy$x[full_indices(indices_obscured, n)]
y_obscured <- xy$y[full_indices(indices_obscured, n)]
x_visible <- xy$x[full_indices(indices_visible, n)]
y_visible <- xy$y[full_indices(indices_visible, n)]
polygonGrob(x=c(x_obscured, x_visible),
y=c(y_obscured, y_visible),
id.lengths = c(length(x_obscured), length(x_visible)),
default.units="in", name = name)
}),
active = list()
)
full_indices <- function(indices, n) c(indices, rev(2 * n + 1 - indices))
## Convex, open curved edge
CurvedEdge <- R6Class("edge_curved", inherit = Edge,
public = list(op_grob = function(angle, scale, name = NULL) {
if (self$is_perpendicular_xyplane) {
private$op_grob_perpendicular(angle, scale, name = name)
} else {
private$op_grob_nonperpendicular(angle, scale, name = name)
}
}),
private = list(
op_grob_nonperpendicular = function(angle, scale, name = NULL) {
xy <- self$vertices$project_op(angle, scale)
xyh <- xy$convex_hull
xy_visible <- self$vertices_visible_side(angle)$project_op(angle, scale)
xyh_visible <- xy_visible$convex_hull
A <- list(list(x = xyh$x, y = xyh$y))
B <- list(list(x = xyh_visible$x, y = xyh_visible$y))
xy_minus <- gridGeometry::polyclip(A, B, op = "minus")
#### also include obscured edge (i.e. A intersection B)?
gridGeometry::xyListPolygon(xy_minus, name = name)
},
op_grob_perpendicular = function(angle, scale, name = NULL) {
n <- length(self$vertices) / 2
xy_f <- self$vertices[seq(n)]$project_op(angle, scale)
projections <- numeric(n)
proj_vec <- Vector$new(to_x(angle - 90, 1), to_y(angle - 90, 1))
for (ii in seq(n)) {
projections[ii] <- proj_vec$dot(xy_f[ii])
}
i_min <- which.min(projections)
i_max <- which.max(projections)
l_indices <- list()
i_l <- min(i_min, i_max)
i_u <- max(i_min, i_max)
if (i_l == 1 && i_u == n) {
l_indices[[1]] <- seq(n)
} else if (i_l == 1) {
l_indices[[1]] <- seq(i_u + 1, n)
l_indices[[2]] <- seq(1, i_u)
} else if (i_u == n) {
l_indices[[1]] <- seq(1, i_l - 1)
l_indices[[2]] <- seq(i_l, n)
} else {
l_indices[[1]] <- seq(1, i_l - 1)
l_indices[[2]] <- seq(i_u + 1, n)
l_indices[[3]] <- seq(i_l, i_u)
}
xy <- self$vertices$project_op(angle, scale)
x <- numeric(0)
y <- numeric(0)
id <- numeric(0)
# figure out which part farthest
r <- 10 * self$vertices$width
op_diff <- Point2D$new(0, 0)$translate_polar(angle, r)
op_diff <- Point3D$new(op_diff, z = r / sqrt(2))
op_ref <- self$vertices$c$translate(op_diff)
dists <- sapply(l_indices,
function(x) {
indices <- full_indices(x, n)
op_ref$distance_to(self$vertices[indices]$c)
})
l_indices <- l_indices[order(dists)]
for (i in seq_along(l_indices)) {
indices <- full_indices(l_indices[[i]], n)
x <- append(x, xy$x[indices])
y <- append(y, xy$y[indices])
id <- append(id, rep(i, length(indices)))
}
polygonGrob(x=x, y=y, id=id, default.units="in", name = name)
}),
active = list()
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.