Native scene graph: a faceted scatterplot in pure grrr
Source:vignettes/native-scene-graph.Rmd
native-scene-graph.RmdGoal
Focus on the facetted native scene and its debug overlays for layout validation.
vs_cols <- c("V-shape" = "#E05C40", "Straight" = "#3A7FC1")
expand_range <- function(r, mult = 0.04, add = 0) {
span <- diff(r)
pad <- if (is.finite(span) && span > 0) span * mult else max(abs(r), 1) * mult
c(r[1] - pad - add, r[2] + pad + add)
}
in_bounds_breaks <- function(breaks, lim, tol = 1e-9) {
breaks[breaks >= (lim[1] - tol) & breaks <= (lim[2] + tol)]
}
mm_vp <- function(left, bottom, width, height, clip = FALSE) {
vp(x = mm(left), y = mm(bottom), w = mm(width), h = mm(height), clip = clip)
}
debug_box <- function(label, fill = "#66CCFF", border = "#336699") {
grab_bag(
children = list(
grab_atom("rect", dfr(xmin = 0, ymin = 0, xmax = 1, ymax = 1, fill = fill, colour = border, linewidth = 0.6)),
grab_atom("text", dfr(x = 0.5, y = 0.5, label = label, size = 4, colour = "#0F3550", hjust = 0.5, vjust = 0.5, fontface = "bold"))
),
aesthetics = aes_spec(alpha = 0.22)
)
}
save_scene_svg <- function(scene_obj, stem) {
fig_file <- paste0(knitr::fig_path(), ".svg")
dir.create(dirname(fig_file), recursive = TRUE, showWarnings = FALSE)
dev <- device_svg()
render_scene(scene_obj, dev)
dev@save(fig_file)
# Keep stable copies in-repo for direct inspection outside the browser.
pkg_root <- if (file.exists("DESCRIPTION")) {
"."
} else if (file.exists("../DESCRIPTION")) {
".."
} else {
getwd()
}
out_dir <- file.path(pkg_root, "examples", "native-scene-graph_svg")
dir.create(out_dir, recursive = TRUE, showWarnings = FALSE)
dev@save(file.path(out_dir, paste0(stem, ".svg")))
cat(sprintf('<figure class="external-svg"><img src="%s" alt="%s" /></figure>\n', fig_file, stem))
invisible(fig_file)
}Facetted Scene
Below is the facetted version, kept for debugging and incremental layout fixes.
dat_f <- mtcars[, c("mpg", "wt", "cyl", "vs")]
dat_f$vs <- factor(dat_f$vs, labels = c("V-shape", "Straight"))
cyls_f <- sort(unique(dat_f$cyl))
n_panels_f <- length(cyls_f)
x_range_f <- expand_range(range(dat_f$wt), mult = 0.04)
y_range_f <- expand_range(range(dat_f$mpg), mult = 0.04)
scale_x_f <- function(x) (x - x_range_f[1]) / diff(x_range_f)
scale_y_f <- function(y) (y - y_range_f[1]) / diff(y_range_f)
x_breaks_f <- c(2, 3, 4, 5)
y_breaks_f <- c(10, 15, 20, 25, 30)
x_breaks_f_use <- in_bounds_breaks(x_breaks_f, x_range_f)
y_breaks_f_use <- in_bounds_breaks(y_breaks_f, y_range_f)
panel_bg_f <- function(fill = "#F5F5F5", border = "#CCCCCC") {
grab_atom("rect", dfr(xmin = 0, ymin = 0, xmax = 1, ymax = 1, fill = fill, colour = border, linewidth = 0.4))
}
panel_grid_f <- function(x_breaks_npc, y_breaks_npc, col = "white", lw = 0.6) {
x_breaks_npc <- x_breaks_npc[is.finite(x_breaks_npc) & x_breaks_npc >= 0 & x_breaks_npc <= 1]
y_breaks_npc <- y_breaks_npc[is.finite(y_breaks_npc) & y_breaks_npc >= 0 & y_breaks_npc <= 1]
n_x <- length(x_breaks_npc)
n_y <- length(y_breaks_npc)
grab_atom("path", dfr(
x = c(rep(x_breaks_npc, each = 2), rep(c(0, 1), n_y)),
y = c(rep(c(0, 1), n_x), rep(y_breaks_npc, each = 2)),
group = c(rep(seq_len(n_x), each = 2), rep(seq_len(n_y) + n_x, each = 2)),
colour = col,
linewidth = lw,
linetype = "solid"
))
}
panel_points_f <- function(sub, sz = 9) {
cols <- vs_cols[as.character(sub$vs)]
grab_atom("point", dfr(
x = scale_x_f(sub$wt),
y = scale_y_f(sub$mpg),
size = sz,
fill = cols,
colour = "#333333",
stroke = 0.3,
shape = "circle"
))
}
x_axis_layer_f <- function(breaks, label_size = 3.5) {
bk_npc <- scale_x_f(breaks)
keep <- is.finite(bk_npc) & bk_npc >= 0 & bk_npc <= 1
bk_npc <- bk_npc[keep]
breaks <- breaks[keep]
list(
ticks = grab_atom("segment", dfr(x = bk_npc, y = 0.98, xend = bk_npc, yend = 0.84, colour = "#555555", linewidth = 0.35)),
labels = grab_atom("text", dfr(x = bk_npc, y = 0.72, label = as.character(breaks), size = label_size, hjust = 0.5, vjust = 1, colour = "#333333"))
)
}
y_axis_layer_f <- function(breaks, label_size = 3.5) {
bk_npc <- scale_y_f(breaks)
keep <- is.finite(bk_npc) & bk_npc >= 0 & bk_npc <= 1
bk_npc <- bk_npc[keep]
breaks <- breaks[keep]
list(
ticks = grab_atom("segment", dfr(x = 0.90, y = bk_npc, xend = 1, yend = bk_npc, colour = "#555555", linewidth = 0.35)),
labels = grab_atom("text", dfr(x = 0.86, y = bk_npc, label = as.character(breaks), size = label_size, hjust = 1, vjust = 0.5, colour = "#333333"))
)
}
strip_header_f <- function(cyl_val, fill = "#3A3A5C", text_col = "white", label_size = 4) {
list(
grab_atom("rect", dfr(xmin = 0, ymin = 0, xmax = 1, ymax = 1, fill = fill, colour = fill, linewidth = 0)),
grab_atom("text", dfr(x = 0.5, y = 0.5, label = paste0("cyl = ", cyl_val), size = label_size, colour = text_col, hjust = 0.5, vjust = 0.5, fontface = "bold"))
)
}
Wf <- 220
Hf <- 130
title_h_f <- 10
strip_h_f <- 8
xaxis_h_f <- 12
yaxis_w_f <- 16
legend_w_f <- 22
layout_gap_f <- 2
panel_gap_f <- 2
panel_bottom_f <- xaxis_h_f
panel_h_f <- Hf - title_h_f - strip_h_f - panel_bottom_f
panel_area_w_f <- Wf - yaxis_w_f - legend_w_f - layout_gap_f
panel_w_f <- (panel_area_w_f - panel_gap_f * (n_panels_f - 1)) / n_panels_f
legend_x_f <- yaxis_w_f + panel_area_w_f + layout_gap_f
facet_groups <- lapply(seq_along(cyls_f), function(i) {
cyl_val <- cyls_f[[i]]
sub <- dat_f[dat_f$cyl == cyl_val, ]
left <- yaxis_w_f + (i - 1) * (panel_w_f + panel_gap_f)
panel <- grab_bag(
children = list(
panel_bg_f(),
panel_grid_f(scale_x_f(x_breaks_f_use), scale_y_f(y_breaks_f_use)),
panel_points_f(sub)
),
viewport = mm_vp(left, panel_bottom_f, panel_w_f, panel_h_f, clip = TRUE)
)
hdr <- grab_bag(children = strip_header_f(cyl_val), viewport = mm_vp(left, panel_bottom_f + panel_h_f, panel_w_f, strip_h_f))
xax <- x_axis_layer_f(x_breaks_f_use)
x_tick_group <- grab_bag(children = list(xax$ticks), viewport = mm_vp(left, xaxis_h_f * 0.55, panel_w_f, xaxis_h_f * 0.45))
x_lbl_group <- grab_bag(children = list(xax$labels), viewport = mm_vp(left, 0, panel_w_f, xaxis_h_f * 0.85))
list(panel = panel, hdr = hdr, x_tick = x_tick_group, x_lbl = x_lbl_group)
})
yax_f <- y_axis_layer_f(y_breaks_f_use)
y_ticks_f <- grab_bag(children = list(yax_f$ticks), viewport = mm_vp(0, panel_bottom_f, yaxis_w_f, panel_h_f))
y_labels_f <- grab_bag(children = list(yax_f$labels), viewport = mm_vp(0, panel_bottom_f, yaxis_w_f, panel_h_f))
y_title_f <- grab_bag(
children = list(grab_atom("text", dfr(x = 0.5, y = 0.5, label = "Miles per gallon (mpg)", size = 4, colour = "#333333", angle = 90, hjust = 0.5, vjust = 0.5))),
viewport = mm_vp(0, panel_bottom_f, yaxis_w_f * 0.45, panel_h_f)
)
x_title_f <- grab_bag(
children = list(grab_atom("text", dfr(x = 0.5, y = 0.3, label = "Weight (1000 lbs)", size = 4, colour = "#333333", hjust = 0.5, vjust = 0))),
viewport = mm_vp(yaxis_w_f, 0, Wf - yaxis_w_f, xaxis_h_f)
)
title_bar_f <- grab_bag(
children = list(
grab_atom("rect", dfr(xmin = 0, ymin = 0, xmax = 1, ymax = 1, fill = "#1E1E2E", colour = "#1E1E2E", linewidth = 0)),
grab_atom("text", dfr(x = 0.5, y = 0.5, label = "Fuel efficiency vs weight — mtcars (faceted by cylinders)", size = 4.5, colour = "white", hjust = 0.5, vjust = 0.5, fontface = "bold"))
),
viewport = mm_vp(0, Hf - title_h_f, Wf, title_h_f)
)
legend_items_f <- Map(function(lbl, col, i) {
y_pos <- 0.75 - (i - 1) * 0.35
list(
grab_atom("point", dfr(x = 0.12, y = y_pos + 0.05, size = 9, fill = col, colour = "#333333", stroke = 0.3, shape = "circle")),
grab_atom("text", dfr(x = 0.22, y = y_pos + 0.05, label = lbl, size = 3.5, hjust = 0, vjust = 0.5, colour = "#333333"))
)
}, names(vs_cols), vs_cols, seq_along(vs_cols))
legend_box_f <- grab_bag(
children = c(
list(grab_atom("rect", dfr(xmin = 0, ymin = 0, xmax = 1, ymax = 1, fill = "white", colour = "#AAAAAA", linewidth = 0.4))),
unlist(legend_items_f, recursive = FALSE)
),
viewport = mm_vp(legend_x_f, panel_bottom_f + panel_h_f * 0.56, legend_w_f, panel_h_f * 0.40)
)
scene_facet <- scene(
children = c(
list(title_bar_f, y_ticks_f, y_labels_f, y_title_f, x_title_f, legend_box_f),
lapply(facet_groups, `[[`, "panel"),
lapply(facet_groups, `[[`, "hdr"),
lapply(facet_groups, `[[`, "x_tick"),
lapply(facet_groups, `[[`, "x_lbl")
),
width_mm = Wf,
height_mm = Hf
)
debug_boxes_f <- c(
list(
grab_bag(children = list(debug_box("title", "#FECACA", "#B91C1C")), viewport = mm_vp(0, Hf - title_h_f, Wf, title_h_f)),
grab_bag(children = list(debug_box("y labels", "#E9D5FF", "#7E22CE")), viewport = mm_vp(0, panel_bottom_f, yaxis_w_f, panel_h_f)),
grab_bag(children = list(debug_box("y title", "#DDD6FE", "#6D28D9")), viewport = mm_vp(0, panel_bottom_f, yaxis_w_f * 0.45, panel_h_f)),
grab_bag(children = list(debug_box("x title", "#BBF7D0", "#15803D")), viewport = mm_vp(yaxis_w_f, 0, Wf - yaxis_w_f, xaxis_h_f)),
grab_bag(children = list(debug_box("legend", "#FDE68A", "#B45309")), viewport = mm_vp(legend_x_f, panel_bottom_f + panel_h_f * 0.56, legend_w_f, panel_h_f * 0.40))
),
unlist(lapply(seq_along(cyls_f), function(i) {
left <- yaxis_w_f + (i - 1) * (panel_w_f + panel_gap_f)
list(
grab_bag(children = list(debug_box(paste0("panel ", i), "#BFDBFE", "#1D4ED8")), viewport = mm_vp(left, panel_bottom_f, panel_w_f, panel_h_f)),
grab_bag(children = list(debug_box(paste0("strip ", i), "#FBCFE8", "#BE185D")), viewport = mm_vp(left, panel_bottom_f + panel_h_f, panel_w_f, strip_h_f)),
grab_bag(children = list(debug_box(paste0("x ticks ", i), "#A7F3D0", "#047857")), viewport = mm_vp(left, 0, panel_w_f, xaxis_h_f * 0.45)),
grab_bag(children = list(debug_box(paste0("x labels ", i), "#86EFAC", "#166534")), viewport = mm_vp(left, 0, panel_w_f, xaxis_h_f * 0.85))
)
}), recursive = FALSE)
)
scene_facet_debug <- scene(
children = c(scene_facet@children, debug_boxes_f),
width_mm = Wf,
height_mm = Hf
)
