| 1 |
# render.R — HTML rendering and display |
|
| 2 | ||
| 3 |
# ── Internal: locate and read the bundled JS ─────────────────────────────────── |
|
| 4 | ||
| 5 |
.bundle_js <- function() {
|
|
| 6 | 23x |
path <- system.file("htmlwidgets", "lib", "qeviz", "qeviz.umd.js", package = "qeviz")
|
| 7 | 23x |
if (!nzchar(path) || !file.exists(path)) |
| 8 | ! |
stop("qeviz.umd.js not found in package inst/. Re-install the package.")
|
| 9 | 23x |
js <- paste(readLines(path, warn = FALSE), collapse = "\n") |
| 10 |
# Inlined into a page, the relative source-map URL would resolve against the |
|
| 11 |
# page and 404; the map is only served with the file-based dependency. |
|
| 12 | 23x |
sub("\n//# sourceMappingURL=[^\n]*\\s*$", "\n", js)
|
| 13 |
} |
|
| 14 | ||
| 15 |
# ── Internal: accept either a raw rENA set, a pre-extracted ModelData list, |
|
| 16 |
# or a qe_plot object ──────────────────────────────────────────── |
|
| 17 |
# |
|
| 18 |
# • ena.set objects → qe_extract() with any forwarded args |
|
| 19 |
# • qe_plot objects → return the model slot directly |
|
| 20 |
# • anything else → assumed to be a ModelData list already |
|
| 21 |
.to_model <- function(x, ...) {
|
|
| 22 | 3x |
if (inherits(x, "qe_plot")) return(x$model) |
| 23 | ! |
if (inherits(x, "ena.set")) return(qe_extract(x, ...)) |
| 24 | 132x |
x |
| 25 |
} |
|
| 26 | ||
| 27 |
# ── Internal: resolve graph_opts from a qe_plot object or plain list ────────── |
|
| 28 |
# When x is a qe_plot, its stored opts are used as the base; the caller can |
|
| 29 |
# still pass graph_opts to override individual keys. |
|
| 30 |
.resolve_opts <- function(x, graph_opts = list()) {
|
|
| 31 | 23x |
base <- if (inherits(x, "qe_plot")) x$graph_opts else list() |
| 32 | 23x |
utils::modifyList(base, graph_opts) |
| 33 |
} |
|
| 34 | ||
| 35 |
# ── Internal: resolve title ─────────────────────────────────────────────────── |
|
| 36 |
.resolve_title <- function(x, title) {
|
|
| 37 | 1x |
if (!is.null(title)) return(title) |
| 38 | 3x |
if (inherits(x, "qe_plot")) x$title %||% "qeviz" else "qeviz" |
| 39 |
} |
|
| 40 | ||
| 41 |
# ── Internal: build the <qe-graph> element with child layer elements ────────── |
|
| 42 |
# |
|
| 43 |
# Each declarative child element maps directly to a rendering layer: |
|
| 44 |
# <qe-nodes> — code nodes (emitted with an edge network, or via qe_nodes()) |
|
| 45 |
# <qe-means> — group mean markers + CI boxes (omit to hide) |
|
| 46 |
# <qe-points> — unit scatter dots (omit to hide) |
|
| 47 |
# <qe-edges> — edge network (omit to hide) |
|
| 48 |
# <qe-trajectories> — ordered unit paths (omit to hide) |
|
| 49 |
# |
|
| 50 |
# Presence of a child = the layer renders. |
|
| 51 |
# Absence = the layer is hidden. |
|
| 52 |
# DOM order = SVG render order (later children draw on top). |
|
| 53 | ||
| 54 |
.build_graph_element <- function(opts) {
|
|
| 55 | 115x |
w <- opts[["width"]] %||% "100%" |
| 56 | 115x |
h <- opts[["height"]] %||% "440" |
| 57 | 115x |
children <- character(0) |
| 58 | ||
| 59 |
# <qe-nodes> is emitted after <qe-edges> is decided (see .nodes_element()), |
|
| 60 |
# but placed first so DOM order is unchanged. |
|
| 61 | 115x |
nodes_at <- length(children) + 1L |
| 62 | ||
| 63 |
# ── <qe-means> — show group means + optional CI boxes ──────────────────── |
|
| 64 |
# Present by default so `qe_plot(set)` shows group means; omitted after |
|
| 65 |
# qe_group(show = FALSE). |
|
| 66 | 115x |
means_parts <- character(0) |
| 67 | 115x |
if (!is.null(opts[["groups"]])) |
| 68 | 6x |
means_parts <- c(means_parts, sprintf('groups="%s"', opts[["groups"]]))
|
| 69 | 115x |
if (!isFALSE(opts[["confidence"]])) |
| 70 | 113x |
means_parts <- c(means_parts, "confidence") |
| 71 | 115x |
if (!is.null(opts[["intervals"]]) && opts[["intervals"]] != "box") |
| 72 | 4x |
means_parts <- c(means_parts, sprintf('intervals="%s"', opts[["intervals"]]))
|
| 73 | 115x |
if (isTRUE(opts[["mean-outlier"]])) |
| 74 | 2x |
means_parts <- c(means_parts, "outlier") |
| 75 | 115x |
means_label <- opts[["label-means"]] %||% "on" |
| 76 | 115x |
means_parts <- c(means_parts, sprintf('label="%s"', means_label))
|
| 77 | 115x |
if (!is.null(opts[["label-weight-means"]])) |
| 78 | ! |
means_parts <- c(means_parts, sprintf('label-font-weight="%s"', opts[["label-weight-means"]]))
|
| 79 | 115x |
if (isTRUE(opts[["mean-fixed-size"]])) |
| 80 | 1x |
means_parts <- c(means_parts, "fixed-size") |
| 81 | 115x |
if (!isFALSE(opts[["means-show"]])) |
| 82 | 114x |
children <- c(children, |
| 83 | 114x |
sprintf(' <qe-means %s></qe-means>', paste(means_parts, collapse = " ")))
|
| 84 | ||
| 85 |
# ── <qe-points> — unit scatter dots (only when points = TRUE) ──────────── |
|
| 86 | 115x |
if (isTRUE(opts[["points"]])) {
|
| 87 | 5x |
pt_label <- opts[["label-points"]] %||% "auto" |
| 88 | 5x |
pt_parts <- sprintf('label="%s"', pt_label)
|
| 89 | 5x |
if (!is.null(opts[["label-weight-points"]])) |
| 90 | ! |
pt_parts <- c(pt_parts, sprintf('label-font-weight="%s"', opts[["label-weight-points"]]))
|
| 91 | 5x |
if (!is.null(opts[["point-size"]])) |
| 92 | 2x |
pt_parts <- c(pt_parts, sprintf('size="%s"', opts[["point-size"]]))
|
| 93 | 5x |
if (isTRUE(opts[["point-fixed-size"]])) |
| 94 | 1x |
pt_parts <- c(pt_parts, "fixed-size") |
| 95 | 5x |
children <- c(children, |
| 96 | 5x |
sprintf(' <qe-points %s></qe-points>', paste(pt_parts, collapse = " ")))
|
| 97 |
} |
|
| 98 |
# Explicit point sets (qe_points(units =, points =)). |
|
| 99 | 115x |
for (ps in opts[["point-sets"]] %||% list()) {
|
| 100 | 1x |
pt_parts <- c(sprintf('set="%s"', ps$set),
|
| 101 | 1x |
sprintf('label="%s"', opts[["label-points"]] %||% "auto"),
|
| 102 | 1x |
if (!is.null(opts[["label-weight-points"]])) |
| 103 | 1x |
sprintf('label-font-weight="%s"', opts[["label-weight-points"]]),
|
| 104 | 1x |
if (!is.null(ps$size)) sprintf('size="%s"', ps$size),
|
| 105 | 1x |
if (isTRUE(ps$fixed)) "fixed-size") |
| 106 | 1x |
children <- c(children, |
| 107 | 1x |
sprintf(' <qe-points %s></qe-points>', paste(pt_parts, collapse = " ")))
|
| 108 |
} |
|
| 109 | ||
| 110 |
# ── <qe-edges> — edge network (omit when no primary target or suppressed) ─ |
|
| 111 |
# Emitted only when at least one of group/unit is set (or compare/also are, |
|
| 112 |
# though those require a primary). The R chain functions validate this. |
|
| 113 | 115x |
if (!identical(opts[["edges"]], "false")) {
|
| 114 | 115x |
edge_parts <- character(0) |
| 115 | 115x |
if (!is.null(opts[["group"]])) |
| 116 | 34x |
edge_parts <- c(edge_parts, sprintf('group="%s"', opts[["group"]]))
|
| 117 | 115x |
if (!is.null(opts[["unit"]])) |
| 118 | ! |
edge_parts <- c(edge_parts, sprintf('unit="%s"', opts[["unit"]]))
|
| 119 | 115x |
if (!is.null(opts[["compare"]])) |
| 120 | ! |
edge_parts <- c(edge_parts, sprintf('compare="%s"', opts[["compare"]]))
|
| 121 | 115x |
if (!is.null(opts[["also"]])) |
| 122 | ! |
edge_parts <- c(edge_parts, sprintf('also="%s"', opts[["also"]]))
|
| 123 |
# Layer attributes (0.5): colors / threshold / name for the named network, |
|
| 124 |
# then one <qe-edges network="…"> per explicit layer. |
|
| 125 | 115x |
attr_parts <- function(a) vapply(names(a), function(k) sprintf('%s="%s"', k, a[[k]]), "")
|
| 126 | 115x |
layers <- list() |
| 127 | 115x |
if (length(edge_parts) > 0) |
| 128 | 34x |
layers <- list(c(edge_parts, attr_parts(opts[["edge-named"]] %||% list()))) |
| 129 | 7x |
for (L in opts[["edge-layers"]] %||% list()) layers <- c(layers, list(attr_parts(L))) |
| 130 |
# Plot-wide settings ride on the first layer. |
|
| 131 | 115x |
if (length(layers) > 0) {
|
| 132 | 38x |
if (!is.null(opts[["edge-magnify"]])) |
| 133 | 4x |
layers[[1]] <- c(layers[[1]], sprintf('magnify="%s"', opts[["edge-magnify"]]))
|
| 134 | 38x |
if (!is.null(opts[["edge-color-scale"]])) |
| 135 | 4x |
layers[[1]] <- c(layers[[1]], sprintf('color-scale="%s"', opts[["edge-color-scale"]]))
|
| 136 |
} |
|
| 137 |
# Edge sizing (qe_edges(fixed_size =, self_size =)) applies to every layer. |
|
| 138 | 115x |
for (i in seq_along(layers)) {
|
| 139 | 41x |
if (isTRUE(opts[["edge-fixed-size"]])) |
| 140 | 4x |
layers[[i]] <- c(layers[[i]], "fixed-size") |
| 141 | 41x |
if (!is.null(opts[["edge-self-size"]])) |
| 142 | 4x |
layers[[i]] <- c(layers[[i]], sprintf('self-size="%s"', opts[["edge-self-size"]]))
|
| 143 |
} |
|
| 144 | 115x |
for (parts in layers) |
| 145 | 41x |
children <- c(children, |
| 146 | 41x |
sprintf(' <qe-edges %s></qe-edges>', paste(parts, collapse = " ")))
|
| 147 |
} |
|
| 148 | 115x |
has_network <- any(startsWith(children, " <qe-edges")) |
| 149 | ||
| 150 |
# ── <qe-trajectories> — ordered unit trajectories ─────────────────────── |
|
| 151 | 115x |
if (isTRUE(opts[["trajectories"]])) {
|
| 152 | 2x |
traj_parts <- character(0) |
| 153 | 2x |
if (!is.null(opts[["trajectory-units"]])) |
| 154 | 2x |
traj_parts <- c(traj_parts, sprintf('units="%s"', opts[["trajectory-units"]]))
|
| 155 | 2x |
traj_parts <- c(traj_parts, |
| 156 | 2x |
sprintf('smooth="%s"', opts[["trajectory-smooth"]] %||% "none"),
|
| 157 | 2x |
sprintf('max-degree="%s"', opts[["trajectory-max-degree"]] %||% "3"),
|
| 158 | 2x |
sprintf('degree-selection="%s"', opts[["trajectory-degree-selection"]] %||% "loocv_2d"),
|
| 159 | 2x |
sprintf('points="%s"', if (isFALSE(opts[["trajectory-points"]])) "false" else "true"),
|
| 160 | 2x |
sprintf('tips="%s"', if (isFALSE(opts[["trajectory-tips"]])) "false" else "true")
|
| 161 |
) |
|
| 162 | 2x |
if (!is.null(opts[["trajectory-playhead"]])) |
| 163 | ! |
traj_parts <- c(traj_parts, sprintf('playhead="%s"', opts[["trajectory-playhead"]]))
|
| 164 | 2x |
traj_parts <- c(traj_parts, |
| 165 | 2x |
sprintf('line-style="%s"', opts[["trajectory-line-style"]] %||% "uniform"),
|
| 166 | 2x |
sprintf('stroke-width="%s"', opts[["trajectory-stroke-width"]] %||% "2"),
|
| 167 | 2x |
sprintf('stroke-width-range="%s"', opts[["trajectory-stroke-width-range"]] %||% "1,6"),
|
| 168 | 2x |
sprintf('opacity-range="%s"', opts[["trajectory-opacity-range"]] %||% "0.3,1")
|
| 169 |
) |
|
| 170 | 2x |
children <- c(children, |
| 171 | 2x |
sprintf(' <qe-trajectories %s></qe-trajectories>', paste(traj_parts, collapse = " ")))
|
| 172 |
} |
|
| 173 | ||
| 174 |
# ── <qe-axes> — axis lines + optional per-axis labels ─────────────────── |
|
| 175 | 115x |
if (isTRUE(opts[["axes"]])) {
|
| 176 | 10x |
axis_parts <- character(0) |
| 177 | 10x |
ax <- opts[["axis-x"]] |
| 178 | 10x |
ay <- opts[["axis-y"]] |
| 179 |
# TRUE → boolean attribute (label defaults to dimension name); |
|
| 180 |
# a string → attribute with that value; FALSE/NULL → no attribute. |
|
| 181 | 2x |
if (isTRUE(ax)) axis_parts <- c(axis_parts, "x") |
| 182 | 2x |
else if (is.character(ax)) axis_parts <- c(axis_parts, sprintf('x="%s"', ax))
|
| 183 | 2x |
if (isTRUE(ay)) axis_parts <- c(axis_parts, "y") |
| 184 | ! |
else if (is.character(ay)) axis_parts <- c(axis_parts, sprintf('y="%s"', ay))
|
| 185 | 4x |
if (isTRUE(opts[["axes-fixed-size"]])) axis_parts <- c(axis_parts, "fixed-size") |
| 186 | 10x |
children <- c(children, |
| 187 | 10x |
sprintf(' <qe-axes%s></qe-axes>',
|
| 188 | 10x |
if (length(axis_parts)) paste0(" ", paste(axis_parts, collapse = " ")) else ""))
|
| 189 |
} |
|
| 190 | ||
| 191 |
# ── <qe-nodes> — draw code nodes (positions always come from the model) ── |
|
| 192 |
# "auto" draws them only with an edge network, as rENA does. |
|
| 193 | 115x |
node_show <- opts[["nodes-show"]] %||% "auto" |
| 194 | 115x |
if (node_show == "always" || (node_show == "auto" && has_network)) {
|
| 195 | 41x |
node_label <- opts[["label-nodes"]] %||% "on" |
| 196 | 41x |
unconn <- if (identical(opts[["nodes-unconnected"]], "hide")) ' unconnected="hide"' else "" |
| 197 | 41x |
extra <- paste0( |
| 198 | 41x |
if (!is.null(opts[["label-weight-nodes"]])) |
| 199 | 41x |
sprintf(' label-font-weight="%s"', opts[["label-weight-nodes"]]) else "",
|
| 200 | 41x |
if (isTRUE(opts[["nodes-fixed-size"]])) " fixed-size" else "") |
| 201 | 41x |
children <- append(children, |
| 202 | 41x |
sprintf(' <qe-nodes label="%s"%s%s></qe-nodes>', node_label, unconn, extra),
|
| 203 | 41x |
after = nodes_at - 1L) |
| 204 |
} |
|
| 205 | ||
| 206 | 115x |
children_str <- paste(children, collapse = "\n") |
| 207 |
# Plot-wide attributes on <qe-graph> (values HTML-escaped). |
|
| 208 | 115x |
esc <- function(v) gsub('"', """, gsub("<", "<", gsub("&", "&", as.character(v), fixed = TRUE),
|
| 209 | 115x |
fixed = TRUE), fixed = TRUE) |
| 210 | 115x |
gattr <- c("edge-width", "plot-title", "range", "center", "scale-points", "point-scale",
|
| 211 | 115x |
"view-padding", "label-font-size", "label-font-family", "label-font-color") |
| 212 | 115x |
ga <- paste0(vapply(gattr, function(k) |
| 213 | 115x |
if (is.null(opts[[k]])) "" else sprintf(' %s="%s"', k, esc(opts[[k]])), ""), collapse = "")
|
| 214 | 115x |
sprintf('<qe-graph width="%s" height="%s"%s>\n%s\n </qe-graph>', w, h, ga, children_str)
|
| 215 |
} |
|
| 216 | ||
| 217 |
# ── Internal: build the full HTML document string ───────────────────────────── |
|
| 218 | ||
| 219 |
.build_html <- function(model_json, title = "qeviz", graph_opts = list()) {
|
|
| 220 | 15x |
bundle <- .bundle_js() |
| 221 | 15x |
graph_elem <- .build_graph_element(graph_opts) |
| 222 | ||
| 223 | 15x |
sprintf('<!DOCTYPE html>
|
| 224 | 15x |
<html lang="en"> |
| 225 | 15x |
<head> |
| 226 | 15x |
<meta charset="UTF-8"> |
| 227 | 15x |
<meta name="viewport" content="width=device-width, initial-scale=1.0"> |
| 228 | 15x |
<title>%s</title> |
| 229 | 15x |
<style> |
| 230 | 15x |
* { box-sizing: border-box; }
|
| 231 | 15x |
body { font-family: system-ui, sans-serif; margin: 0; padding: 0; background: #fff; }
|
| 232 | 15x |
qe-visual { display: block; width: 100%%; height: 480px; }
|
| 233 | 15x |
qe-graph { display: block; width: 100%%; height: 100%%; }
|
| 234 | 15x |
</style> |
| 235 | 15x |
</head> |
| 236 | 15x |
<body> |
| 237 | 15x |
<qe-visual id="vis"> |
| 238 | 15x |
%s |
| 239 | 15x |
</qe-visual> |
| 240 | 15x |
<script>%s</script> |
| 241 | 15x |
<script> |
| 242 | 15x |
const model = %s; |
| 243 | 15x |
document.getElementById("vis").setModelData(model);
|
| 244 | 15x |
</script> |
| 245 | 15x |
</body> |
| 246 | 15x |
</html>', title, graph_elem, bundle, model_json) |
| 247 |
} |
|
| 248 | ||
| 249 |
# ── NULL-coalescing helper ───────────────────────────────────────────────────── |
|
| 250 | 1005x |
`%||%` <- function(a, b) if (!is.null(a)) a else b |
| 251 | ||
| 252 | ||
| 253 |
# ══ qe_plot object ════════════════════════════════════════════════════════════ |
|
| 254 | ||
| 255 |
#' Create a qeviz plot object |
|
| 256 |
#' |
|
| 257 |
#' Returns a `qe_plot` object that can be customised with chained `qe_*()` |
|
| 258 |
#' functions and rendered by printing, [qe_export_html()], or [qe_html()]. |
|
| 259 |
#' |
|
| 260 |
#' `width` and `height` set the plot dimensions and can be supplied here rather |
|
| 261 |
#' than in a separate sizing call. |
|
| 262 |
#' |
|
| 263 |
#' @param x Either a raw rENA / tma / ona set object **or** a `ModelData` |
|
| 264 |
#' list from [qe_model_data()] / [qe_extract()]. |
|
| 265 |
#' @param title Plot title. When given it is drawn at the top of the plot |
|
| 266 |
#' (and included in SVG / PNG exports) and used as the page title; when |
|
| 267 |
#' `NULL` (default) nothing is drawn and the page title is "qeviz". |
|
| 268 |
#' @param width CSS width string. Default `"100%"`. |
|
| 269 |
#' @param height Plot height in pixels (numeric) or any CSS string. Default `440`. |
|
| 270 |
#' @param range Symmetric axis range, as rENA's `scale.to`: `"network"` |
|
| 271 |
#' (±max |node| × 1.2), `"points"` (±max |point| × 1.2) or a positive number. |
|
| 272 |
#' `NULL` (default) uses qeviz's fit (1.3 × the largest mark). Asymmetric |
|
| 273 |
#' ranges (rENA's `list(x =, y =)`) are not supported. |
|
| 274 |
#' @param scale_points Rescale unit points and means so the outermost point |
|
| 275 |
#' meets the outermost code node (default `TRUE`); `FALSE` plots raw |
|
| 276 |
#' coordinates, as rENA does. |
|
| 277 |
#' @param point_scale Multiply unit points and means by this factor instead |
|
| 278 |
#' (a positive number), overriding `scale_points`. `NULL` (default) keeps |
|
| 279 |
#' `scale_points`' behaviour. E.g. `1` for raw coordinates, or a factor |
|
| 280 |
#' matching another tool's plot. |
|
| 281 |
#' @param center Where the view is centred: `"origin"` (default; (0, 0), the |
|
| 282 |
#' ENA convention, where the points' mean sits) or `"content"`, the middle of |
|
| 283 |
#' the nodes' and points' bounding box, so a network that sits off to one side |
|
| 284 |
#' of the origin fills the plot. With `"content"`, `range = "network"` is |
|
| 285 |
#' measured from that centre. |
|
| 286 |
#' @param palette Group colours, assigned in order of appearance. Default: |
|
| 287 |
#' Paul Tol's colour-blind-safe "bright" scheme. See also [qe_colors()]. |
|
| 288 |
#' @param view_padding How far the view extends beyond `range`: the view shows |
|
| 289 |
#' ±range × `view_padding`. `NULL` (default) uses qeviz's 1.2; `1` makes the |
|
| 290 |
#' view match the range exactly, e.g. to frame the plot yourself. |
|
| 291 |
#' @param ... Additional arguments forwarded to [qe_extract()] when `x` is a |
|
| 292 |
#' raw set (e.g. `group_col = "Condition"`, `dims = c("SVD1", "SVD3")`).
|
|
| 293 |
#' Directionality is detected automatically from the set class. |
|
| 294 |
#' |
|
| 295 |
#' @return An object of class `qe_plot`. |
|
| 296 |
#' |
|
| 297 |
#' @examples |
|
| 298 |
#' \dontrun{
|
|
| 299 |
#' qe_plot(set) |
|
| 300 |
#' qe_plot(set, height = 600) |> qe_group("FirstGame")
|
|
| 301 |
#' } |
|
| 302 |
#' |
|
| 303 |
#' @export |
|
| 304 |
qe_plot <- function(x, title = NULL, width = "100%", height = 440, |
|
| 305 |
range = NULL, scale_points = TRUE, point_scale = NULL, |
|
| 306 |
center = c("origin", "content"), palette = NULL,
|
|
| 307 |
view_padding = NULL, ...) {
|
|
| 308 | 118x |
center <- match.arg(center) |
| 309 | 117x |
if (!is.null(view_padding) && !(is.numeric(view_padding) && length(view_padding) == 1L && |
| 310 | 117x |
is.finite(view_padding) && view_padding > 0)) |
| 311 | 1x |
stop("qe_plot(): view_padding must be a positive number.", call. = FALSE)
|
| 312 | 116x |
if (!is.null(point_scale) && !(is.numeric(point_scale) && length(point_scale) == 1L && |
| 313 | 116x |
is.finite(point_scale) && point_scale > 0)) |
| 314 | 2x |
stop("qe_plot(): point_scale must be a positive number.", call. = FALSE)
|
| 315 | 114x |
.qe_check_range(range, "qe_plot") |
| 316 | 112x |
if (!is.null(palette) && !(is.character(palette) && length(palette) >= 1L)) |
| 317 | ! |
stop("qe_plot(): palette must be a character vector of colours.", call. = FALSE)
|
| 318 | 112x |
p <- structure( |
| 319 | 112x |
list( |
| 320 | 112x |
model = .to_model(x, ...), |
| 321 | 112x |
title = title %||% "qeviz", |
| 322 | 112x |
graph_opts = list() |
| 323 |
), |
|
| 324 | 112x |
class = "qe_plot" |
| 325 |
) |
|
| 326 | 112x |
p$graph_opts$width <- width |
| 327 | 112x |
p$graph_opts$height <- as.character(height) |
| 328 | 112x |
p$graph_opts[["plot-title"]] <- title |
| 329 | 112x |
p$graph_opts[["range"]] <- range |
| 330 | 2x |
if (isFALSE(scale_points)) p$graph_opts[["scale-points"]] <- "false" |
| 331 | 2x |
if (center == "content") p$graph_opts[["center"]] <- "content" |
| 332 | 112x |
p$graph_opts[["point-scale"]] <- point_scale |
| 333 | 112x |
p$graph_opts[["view-padding"]] <- view_padding |
| 334 | 1x |
if (!is.null(palette)) p$model$palette <- as.list(palette) |
| 335 | 112x |
p |
| 336 |
} |
|
| 337 | ||
| 338 |
#' Set group colours |
|
| 339 |
#' |
|
| 340 |
#' Pins groups to colours; each group's mean, unit points and networks use |
|
| 341 |
#' it. Unlisted groups keep the palette colour. |
|
| 342 |
#' |
|
| 343 |
#' @param p A `qe_plot` object. |
|
| 344 |
#' @param ... Named colours: `FirstGame = "#E69F00"`, … |
|
| 345 |
#' @return The modified `qe_plot` object. |
|
| 346 |
#' @examples |
|
| 347 |
#' \dontrun{
|
|
| 348 |
#' qe_plot(set) |> qe_colors(FirstGame = "#E69F00", SecondGame = "#56B4E9") |> |
|
| 349 |
#' qe_edges("FirstGame", compare = "SecondGame")
|
|
| 350 |
#' } |
|
| 351 |
#' @export |
|
| 352 |
qe_colors <- function(p, ...) {
|
|
| 353 | 3x |
cols <- unlist(list(...)) |
| 354 | 3x |
if (!length(cols) || is.null(names(cols)) || any(!nzchar(names(cols)))) |
| 355 | 1x |
stop("qe_colors(): give named colours, e.g. qe_colors(p, FirstGame = \"#E69F00\").",
|
| 356 | 1x |
call. = FALSE) |
| 357 | 2x |
bad <- setdiff(names(cols), qe_groups(p)) |
| 358 | 2x |
if (length(bad)) |
| 359 | 1x |
stop(sprintf("qe_colors(): group(s) not found in model: %s", paste(dQuote(bad), collapse = ", ")),
|
| 360 | 1x |
call. = FALSE) |
| 361 | 1x |
g <- .qe_frame_df(p$model$groups) |
| 362 | 1x |
if (is.null(g$color)) g$color <- NA_character_ |
| 363 | 1x |
gcol <- p$model$group_col |
| 364 | 1x |
g$color[match(names(cols), g[[gcol]])] <- unname(cols) |
| 365 | 1x |
p$model$groups <- qe_frame(g) |
| 366 | 1x |
p |
| 367 |
} |
|
| 368 | ||
| 369 | ||
| 370 | ||
| 371 |
# ══ Chain functions ════════════════════════════════════════════════════════════ |
|
| 372 | ||
| 373 |
#' Select which group means to display |
|
| 374 |
#' |
|
| 375 |
#' Controls which groups' mean markers and CI boxes appear in the plot. This |
|
| 376 |
#' is independent of edge rendering — use [qe_edges()] to select whose network |
|
| 377 |
#' to draw. |
|
| 378 |
#' |
|
| 379 |
#' @param p A `qe_plot` object. |
|
| 380 |
#' @param ... Group names to show means for. Supply one or more strings, |
|
| 381 |
#' each matching a value in the model's group column. Omit entirely to show |
|
| 382 |
#' means for **all** groups in the model (the default). |
|
| 383 |
#' @param points An arbitrary subset to average — a matrix, data frame or |
|
| 384 |
#' `ena.points` rows (as rENA's `ena.plot.group()` accepts). Its mean, t CI |
|
| 385 |
#' and (with `outlier`) fences are computed here and added as a group named |
|
| 386 |
#' `label`. Cannot be combined with group names. |
|
| 387 |
#' @param label Name for an explicit mean. Default `"mean 1"`, `"mean 2"`, …. |
|
| 388 |
#' @param color Colour of an explicit mean. Default: next palette colour. |
|
| 389 |
#' @param shape Marker shape for an explicit mean: `"square"` (default), |
|
| 390 |
#' `"circle"`, `"triangle"` or `"diamond"`. |
|
| 391 |
#' @param by The metadata column used for grouping (e.g. `"Condition"`). |
|
| 392 |
#' Optional — used to validate against the column baked into the model at |
|
| 393 |
#' extraction time. An error is raised if the column name does not match. |
|
| 394 |
#' @param intervals `"box"` (default), `"crosshairs"`, `"both"` (the box with |
|
| 395 |
#' the crosshairs through the mean) or `"none"`; `TRUE` / |
|
| 396 |
#' `FALSE` are accepted as `"box"` / `"none"`. rENA's default is `"none"`. |
|
| 397 |
#' @param conf_level Confidence level of the t interval. Default 0.95. |
|
| 398 |
#' @param outlier Also draw the outlier interval (Q1 − 1.5·IQR … Q3 + 1.5·IQR |
|
| 399 |
#' per dimension). Default `FALSE`. |
|
| 400 |
#' @param show `FALSE` hides all group means (as rENA draws none unless |
|
| 401 |
#' asked). A later `qe_group()` call shows them again. |
|
| 402 |
#' @param fixed_size Logical. When `TRUE`, group mean markers keep a constant |
|
| 403 |
#' on-screen pixel size regardless of data extent, container size, or zoom. |
|
| 404 |
#' Default `FALSE` (markers scale with the coordinate space). |
|
| 405 |
#' |
|
| 406 |
#' @return The modified `qe_plot` object. |
|
| 407 |
#' |
|
| 408 |
#' @examples |
|
| 409 |
#' \dontrun{
|
|
| 410 |
#' # Show means for all groups (default) |
|
| 411 |
#' qe_plot(set) |> qe_group() |
|
| 412 |
#' |
|
| 413 |
#' # Show means for specific groups only |
|
| 414 |
#' qe_plot(set) |> qe_group("FirstGame", "SecondGame")
|
|
| 415 |
#' |
|
| 416 |
#' # Explicit column name — validates against model |
|
| 417 |
#' qe_plot(set) |> qe_group("FirstGame", by = "Condition")
|
|
| 418 |
#' } |
|
| 419 |
#' |
|
| 420 |
#' @export |
|
| 421 |
qe_group <- function(p, ..., points = NULL, label = NULL, color = NULL, shape = NULL, |
|
| 422 |
by = NULL, intervals = c("box", "crosshairs", "both", "none"),
|
|
| 423 |
conf_level = 0.95, outlier = FALSE, fixed_size = FALSE, |
|
| 424 |
show = TRUE) {
|
|
| 425 | 19x |
if (!show) {
|
| 426 | 1x |
p$graph_opts[["means-show"]] <- FALSE |
| 427 | 1x |
return(p) |
| 428 |
} |
|
| 429 | 18x |
p$graph_opts[["means-show"]] <- NULL |
| 430 | 18x |
requested <- c(...) # character vector of group names, or length-0 |
| 431 | ||
| 432 |
# Validate `by` against the model's group_col |
|
| 433 | 18x |
if (!is.null(by)) {
|
| 434 | ! |
model_gcol <- if (inherits(p, "qe_plot")) p$model$group_col else p$group_col |
| 435 | ! |
if (!is.null(model_gcol) && !identical(by, model_gcol)) {
|
| 436 | ! |
stop(sprintf( |
| 437 | ! |
"qe_group(): by = %s does not match the model's group column (%s).\n", |
| 438 | ! |
dQuote(by), dQuote(model_gcol) |
| 439 | ! |
), call. = FALSE) |
| 440 |
} |
|
| 441 |
} |
|
| 442 | 1x |
if (is.logical(intervals)) intervals <- if (isTRUE(intervals)) "box" else "none" |
| 443 | 18x |
intervals <- match.arg(intervals) |
| 444 | 18x |
if (!(is.numeric(conf_level) && length(conf_level) == 1L && conf_level > 0 && conf_level < 1)) |
| 445 | 1x |
stop("qe_group(): conf_level must be a number in (0, 1).", call. = FALSE)
|
| 446 | 17x |
if (!is.null(points) && length(requested)) |
| 447 | 1x |
stop("qe_group(): supply group names or 'points', not both.", call. = FALSE)
|
| 448 | ||
| 449 | 16x |
p$graph_opts$intervals <- intervals |
| 450 | 16x |
p$graph_opts$confidence <- intervals != "none" |
| 451 | 16x |
p$graph_opts[["mean-outlier"]] <- isTRUE(outlier) || isTRUE(p$graph_opts[["mean-outlier"]]) |
| 452 | 16x |
p$graph_opts[["mean-fixed-size"]] <- isTRUE(fixed_size) |
| 453 | ||
| 454 | 16x |
if (!is.null(points)) {
|
| 455 |
# ── Explicit: the mean (+ t CI, outlier fences) of an arbitrary subset ─── |
|
| 456 | 6x |
m <- p$model |
| 457 | 6x |
df <- .qe_point_frame(points, m) |
| 458 | 6x |
lbl <- label %||% sprintf("mean %d", length(p$graph_opts[["groups-explicit"]]) + 1L)
|
| 459 | 6x |
if (lbl %in% qe_groups(p) && !lbl %in% p$graph_opts[["groups-explicit"]]) |
| 460 | 1x |
stop(sprintf("qe_group(): label %s is already a group in the model.", dQuote(lbl)),
|
| 461 | 1x |
call. = FALSE) |
| 462 | 5x |
gkey <- .qe_group_key(m) |
| 463 | 5x |
df[[gkey]] <- lbl |
| 464 | 5x |
row <- group_summary(df, m$x_col, m$y_col, gkey, conf_level = conf_level, |
| 465 | 5x |
outlier = outlier) |
| 466 | 1x |
if (!is.null(color)) row$color <- color |
| 467 | 1x |
if (!is.null(shape)) row$shape <- .qe_shape(shape, "qe_group") |
| 468 |
# Each explicit mean keeps its own intervals / outlier setting (rENA sets |
|
| 469 |
# them per ena.plot.group() call); they override the plot-wide ones. |
|
| 470 | 5x |
row$intervals <- intervals |
| 471 | 5x |
row$outlier <- isTRUE(outlier) |
| 472 | 5x |
p$model$groups <- .qe_upsert_rows(p$model$groups, row, gkey) |
| 473 | 5x |
p$graph_opts[["groups-explicit"]] <- union(p$graph_opts[["groups-explicit"]], lbl) |
| 474 |
} else {
|
|
| 475 |
# ── By name ───────────────────────────────────────────────────────────── |
|
| 476 | 10x |
if (length(requested) > 0) {
|
| 477 | 2x |
available <- qe_groups(p) |
| 478 | 2x |
bad <- requested[!requested %in% available] |
| 479 | 2x |
if (length(bad) > 0) {
|
| 480 | ! |
stop(sprintf( |
| 481 | ! |
"qe_group(): group(s) not found in model: %s\nAvailable: %s", |
| 482 | ! |
paste(dQuote(bad), collapse = ", "), |
| 483 | ! |
paste(dQuote(available), collapse = ", ") |
| 484 | ! |
), call. = FALSE) |
| 485 |
} |
|
| 486 |
} |
|
| 487 | 10x |
p$graph_opts[["groups-named"]] <- as.character(requested) # character(0) = all |
| 488 |
# Non-default CI level / outlier fences: recompute the named groups' rows |
|
| 489 |
# from the unit points (explicit rows keep what they were computed with). |
|
| 490 | 10x |
m <- p$model |
| 491 | 10x |
if ((conf_level != 0.95 || isTRUE(outlier)) && !is.null(m$points)) {
|
| 492 | 1x |
pts <- .qe_frame_df(m$points) |
| 493 | 1x |
rows <- group_summary(pts, m$x_col, m$y_col, m$group_col, |
| 494 | 1x |
conf_level = conf_level, outlier = outlier) |
| 495 | 1x |
p$model$groups <- .qe_upsert_rows(p$model$groups, rows, m$group_col) |
| 496 |
} |
|
| 497 |
} |
|
| 498 | ||
| 499 |
# `groups` filter: named selection (all / some) plus explicit means. With |
|
| 500 |
# only explicit means, show just those (as rENA's ena.plot.group does). |
|
| 501 | 15x |
named <- p$graph_opts[["groups-named"]] |
| 502 | 15x |
expl <- p$graph_opts[["groups-explicit"]] |
| 503 | 15x |
p$graph_opts$groups <- |
| 504 | 8x |
if (!length(expl)) { if (length(named)) paste(named, collapse = ",") else NULL }
|
| 505 | 15x |
else if (is.null(named)) paste(expl, collapse = ",") |
| 506 | 15x |
else if (!length(named)) NULL |
| 507 | 15x |
else paste(c(named, expl), collapse = ",") |
| 508 | 15x |
p |
| 509 |
} |
|
| 510 | ||
| 511 |
#' Select which edge network to draw |
|
| 512 |
#' |
|
| 513 |
#' Controls edge rendering. A network is chosen **by name** — a group |
|
| 514 |
#' (`group`) or a unit (`unit`), optionally with `compare` / `also` — or given |
|
| 515 |
#' **as data** with `weights` (any vector, matrix or data frame, as rENA's |
|
| 516 |
#' `ena.plot.network()` accepts). Name calls replace the plot's named network; |
|
| 517 |
#' `weights` calls add a layer, so repeated calls overlay. `qe_edges(show = |
|
| 518 |
#' FALSE)` clears every network. |
|
| 519 |
#' |
|
| 520 |
#' Use [qe_units()] to inspect the unit IDs present in the model. |
|
| 521 |
#' |
|
| 522 |
#' @param p A `qe_plot` object. |
|
| 523 |
#' @param group Name of the primary group whose **mean** edge network to draw. |
|
| 524 |
#' Must match a value in the model's group column. Mutually exclusive with |
|
| 525 |
#' `unit`. |
|
| 526 |
#' @param unit ID of a single unit whose **individual** edge network to draw |
|
| 527 |
#' (e.g. `"FirstGame::steven z"`). Mutually exclusive with `group`. |
|
| 528 |
#' `compare` and `also` are not supported when `unit` is supplied. |
|
| 529 |
#' @param weights Explicit network data: a named numeric vector (names |
|
| 530 |
#' `"A & B"` or `"A.B"`; missing edges are 0), an unnamed vector in the |
|
| 531 |
#' model's edge-column order, a matrix / data frame of rows (column means; |
|
| 532 |
#' non-numeric columns are dropped, so `set$line.weights[...]` works), or a |
|
| 533 |
#' named list of any of those (one layer each). Signed: positive weights use |
|
| 534 |
#' `colors[1]`, negative `colors[2]`. Drawn on the model's scales — absolute |
|
| 535 |
#' width, and colour from the model-wide range (values beyond it clamp). |
|
| 536 |
#' Mutually exclusive with `group` / `unit`. |
|
| 537 |
#' @param compare Name of a second group to subtract (`group − compare`), or — |
|
| 538 |
#' with `weights` — explicit data in any `weights` form, or a group name |
|
| 539 |
#' (`weights − that group's mean`). Positive differences use the primary |
|
| 540 |
#' colour; negative the secondary. Cannot be combined with `unit`. |
|
| 541 |
#' @param also Name of a second group to overlay alongside `group`. |
|
| 542 |
#' Cannot be combined with `unit`. |
|
| 543 |
#' @param colors `c(positive, negative)` colours for this network, or one |
|
| 544 |
#' colour (negatives then use its complement, as in rENA). Default: the |
|
| 545 |
#' group's palette colour(s); the first two palette colours for `weights`. |
|
| 546 |
#' @param threshold `c(min, max)`, or `min` alone: edges with |weight| < `min` |
|
| 547 |
#' are not drawn and |weight| > `max` is capped at `max` (sign kept) — rENA's |
|
| 548 |
#' `threshold` semantics. |
|
| 549 |
#' @param name Label for this network layer, reported in edge events and |
|
| 550 |
#' tooltips. Default: the group / unit name, list element names, or |
|
| 551 |
#' `"network 1"`, `"network 2"`, …. |
|
| 552 |
#' @param show Logical. `FALSE` clears all networks (named and explicit). |
|
| 553 |
#' Default `TRUE`. |
|
| 554 |
#' @param color_scale How edge weights map to colour, using webENA's ramps |
|
| 555 |
#' (saturation 0.25–1, opacity 0.3–1). `"model"` (default) rescales from the |
|
| 556 |
#' smallest to the largest non-zero weight anywhere in the model, so separate |
|
| 557 |
#' plots of the same model (one group, another group, a unit, a subtraction) |
|
| 558 |
#' share one colour scale. `"plot"` rescales within this plot, as webENA |
|
| 559 |
#' does. `"absolute"` skips the ramps: saturation = opacity = |weight|. |
|
| 560 |
#' @param edge_width Width of an edge of weight 1, as a fraction of the plot |
|
| 561 |
#' width. Width is absolute (raw weight × this), as in webENA, so equal |
|
| 562 |
#' weights draw equally wide in graphs of the same size; each node's |
|
| 563 |
#' diameter is the sum of its edges' widths. `NULL` uses qeviz's default |
|
| 564 |
#' (0.04). |
|
| 565 |
#' @param magnify Multiply this plot's edge widths and node sizes (colour is |
|
| 566 |
#' unchanged), e.g. to make a faint subtraction readable. Whenever it is set |
|
| 567 |
#' — including `1` — the plot is labelled "(scaled N.Nx)", so exported plots |
|
| 568 |
#' state their scaling (webENA labels its side plots "(scaled 1.0x)" for the |
|
| 569 |
#' same reason). `NULL` (default) means no magnification and no label. |
|
| 570 |
#' @param fixed_size Logical. `TRUE` keeps edge widths (lines, directed |
|
| 571 |
#' triangles, self-connection dots, hover targets) at their zoom-1 on-screen |
|
| 572 |
#' width when the plot is zoomed; `FALSE` lets them grow with the zoom (the |
|
| 573 |
#' default behaviour). Applies to every network of the plot. `NULL` |
|
| 574 |
#' (default) leaves the current setting unchanged. |
|
| 575 |
#' @param self_size Size of ONA self-connection dots: `"node"` draws each at |
|
| 576 |
#' half its code node's radius (as webENA does), so the self weight only |
|
| 577 |
#' sets its colour; a positive number is that fraction of the node radius. |
|
| 578 |
#' Applies to every network of the plot. `NULL` (default) leaves the current |
|
| 579 |
#' setting unchanged (initially: sized by weight, like the edges). |
|
| 580 |
#' |
|
| 581 |
#' @return The modified `qe_plot` object. |
|
| 582 |
#' |
|
| 583 |
#' @examples |
|
| 584 |
#' \dontrun{
|
|
| 585 |
#' # Two plots on the same scale (the default): SecondGame's lighter, thinner |
|
| 586 |
#' # lines mean weaker connections, not a different scaling |
|
| 587 |
#' qe_plot(set) |> qe_edges("FirstGame")
|
|
| 588 |
#' qe_plot(set) |> qe_edges("SecondGame")
|
|
| 589 |
#' |
|
| 590 |
#' # Single group mean network, by name or from data |
|
| 591 |
#' qe_plot(set) |> qe_edges("FirstGame")
|
|
| 592 |
#' m <- as.matrix(set$line.weights) |
|
| 593 |
#' fg <- set$meta.data$Condition == "FirstGame" |
|
| 594 |
#' sg <- set$meta.data$Condition == "SecondGame" |
|
| 595 |
#' qe_plot(set) |> qe_edges(weights = m[fg, ]) |
|
| 596 |
#' |
|
| 597 |
#' # Subtraction from data, with explicit colours |
|
| 598 |
#' qe_plot(set) |> qe_edges(weights = m[fg, ], compare = m[sg, ], colors = c("blue", "red"))
|
|
| 599 |
#' |
|
| 600 |
#' # A non-group subset, thresholded |
|
| 601 |
#' qe_plot(set) |> qe_edges(weights = m[set$points$SVD1 > 0, ], threshold = 0.05, |
|
| 602 |
#' name = "SVD1 > 0") |
|
| 603 |
#' |
|
| 604 |
#' # Individual unit network |
|
| 605 |
#' qe_plot(set) |> qe_edges(unit = "FirstGame::steven z") |
|
| 606 |
#' |
|
| 607 |
#' # Individual unit + show all group means |
|
| 608 |
#' qe_plot(set) |> qe_group() |> qe_edges(unit = "FirstGame::steven z") |
|
| 609 |
#' |
|
| 610 |
#' # Subtraction |
|
| 611 |
#' qe_plot(set) |> qe_edges("FirstGame", compare = "SecondGame")
|
|
| 612 |
#' |
|
| 613 |
#' # Overlay |
|
| 614 |
#' qe_plot(set) |> qe_edges("FirstGame", also = "SecondGame")
|
|
| 615 |
#' |
|
| 616 |
#' # No edges (means and/or points only) |
|
| 617 |
#' qe_plot(set) |> qe_group() |> qe_edges(show = FALSE) |
|
| 618 |
#' } |
|
| 619 |
#' |
|
| 620 |
#' @export |
|
| 621 |
qe_edges <- function(p, group = NULL, unit = NULL, weights = NULL, |
|
| 622 |
compare = NULL, also = NULL, |
|
| 623 |
colors = NULL, threshold = NULL, name = NULL, show = TRUE, |
|
| 624 |
color_scale = c("model", "plot", "absolute"), edge_width = NULL,
|
|
| 625 |
magnify = NULL, fixed_size = NULL, self_size = NULL) {
|
|
| 626 | 51x |
if (!is.null(group) && !is.null(unit)) |
| 627 | ! |
stop("qe_edges(): supply either 'group' or 'unit', not both.", call. = FALSE)
|
| 628 | 51x |
if (!is.null(weights) && (!is.null(group) || !is.null(unit))) |
| 629 | 1x |
stop("qe_edges(): supply 'weights' or a 'group' / 'unit' name, not both.", call. = FALSE)
|
| 630 | ||
| 631 | 50x |
if (!show) {
|
| 632 |
# TypeScript reads getAttribute('edges') !== 'false', so we must emit the
|
|
| 633 |
# string "false" — a logical FALSE would be omitted and edges would stay on. |
|
| 634 | 1x |
p$graph_opts$edges <- "false" |
| 635 | 1x |
p$graph_opts$group <- NULL |
| 636 | 1x |
p$graph_opts$unit <- NULL |
| 637 | 1x |
p$graph_opts$compare <- NULL |
| 638 | 1x |
p$graph_opts$also <- NULL |
| 639 | 1x |
p$graph_opts[["edge-named"]] <- NULL |
| 640 | 1x |
p$graph_opts[["edge-layers"]] <- NULL |
| 641 | 1x |
p$model$networks <- NULL |
| 642 | 1x |
return(p) |
| 643 |
} |
|
| 644 | ||
| 645 | 49x |
color_scale <- match.arg(color_scale) |
| 646 | 48x |
if (!is.null(edge_width) && !(is.numeric(edge_width) && length(edge_width) == 1L && |
| 647 | 48x |
is.finite(edge_width) && edge_width > 0 && edge_width <= 1)) |
| 648 | 1x |
stop("qe_edges(): edge_width must be a number in (0, 1].", call. = FALSE)
|
| 649 | 47x |
if (!is.null(magnify) && !(is.numeric(magnify) && length(magnify) == 1L && |
| 650 | 47x |
is.finite(magnify) && magnify > 0)) |
| 651 | 1x |
stop("qe_edges(): magnify must be a positive number.", call. = FALSE)
|
| 652 | 46x |
if (!is.null(fixed_size) && !(is.logical(fixed_size) && length(fixed_size) == 1L && !is.na(fixed_size))) |
| 653 | 1x |
stop("qe_edges(): fixed_size must be TRUE or FALSE.", call. = FALSE)
|
| 654 | 45x |
if (!is.null(self_size) && !(identical(self_size, "node") || |
| 655 | 45x |
(is.numeric(self_size) && length(self_size) == 1L && |
| 656 | 45x |
is.finite(self_size) && self_size > 0))) |
| 657 | 1x |
stop("qe_edges(): self_size must be \"node\" or a positive number.", call. = FALSE)
|
| 658 | 44x |
layer_attrs <- .qe_layer_attrs(colors, threshold) |
| 659 | ||
| 660 | 42x |
p$graph_opts$edges <- TRUE |
| 661 | 42x |
p$graph_opts[["edge-color-scale"]] <- if (color_scale == "model") NULL else color_scale |
| 662 | 2x |
if (!is.null(edge_width)) p$graph_opts[["edge-width"]] <- edge_width |
| 663 | 4x |
if (!is.null(magnify)) p$graph_opts[["edge-magnify"]] <- magnify |
| 664 | 1x |
if (!is.null(fixed_size)) p$graph_opts[["edge-fixed-size"]] <- fixed_size |
| 665 | 1x |
if (!is.null(self_size)) p$graph_opts[["edge-self-size"]] <- self_size |
| 666 | ||
| 667 |
# ── Explicit data: append one layer per network ──────────────────────────── |
|
| 668 | 42x |
if (!is.null(weights)) {
|
| 669 | 13x |
if (!is.null(also)) |
| 670 | ! |
stop("qe_edges(): 'also' takes group names; for data, pass a list to 'weights'.",
|
| 671 | ! |
call. = FALSE) |
| 672 | 13x |
cols <- .qe_edge_columns(p$model) |
| 673 | 13x |
nets <- if (is.list(weights) && !is.data.frame(weights)) weights else list(weights) |
| 674 | 13x |
base <- length(p$graph_opts[["edge-layers"]]) |
| 675 | 13x |
for (k in seq_along(nets)) {
|
| 676 | 14x |
w <- .qe_resolve_weights(nets[[k]], cols, "weights") |
| 677 | 12x |
if (!is.null(compare)) {
|
| 678 | 2x |
w <- w - if (is.character(compare) && length(compare) == 1L) |
| 679 | 2x |
.qe_group_network(p, compare, cols) |
| 680 | 2x |
else .qe_resolve_weights(compare, cols, "compare") |
| 681 |
} |
|
| 682 | 12x |
lname <- if (!is.null(name) && length(nets) == 1L) name |
| 683 | 12x |
else if (!is.null(names(nets)) && nzchar(names(nets)[k])) names(nets)[k] |
| 684 | 12x |
else sprintf("network %d", base + k)
|
| 685 | 12x |
p$model$networks <- .qe_append_network(p$model$networks, lname, w) |
| 686 | 12x |
p$graph_opts[["edge-layers"]] <- c(p$graph_opts[["edge-layers"]], |
| 687 | 12x |
list(c(list(network = lname), layer_attrs))) |
| 688 |
} |
|
| 689 | 11x |
return(p) |
| 690 |
} |
|
| 691 | ||
| 692 |
# ── By name: replace the named network ───────────────────────────────────── |
|
| 693 | 29x |
available_groups <- qe_groups(p) |
| 694 | 29x |
available_units <- qe_units(p) |
| 695 | ||
| 696 |
# Validate group-based targets |
|
| 697 | 29x |
.check_group <- function(name, arg) {
|
| 698 | 84x |
if (!is.null(name) && !name %in% available_groups) {
|
| 699 | ! |
stop(sprintf( |
| 700 | ! |
"qe_edges(): %s = %s not found in model.\nAvailable groups: %s", |
| 701 | ! |
arg, dQuote(name), |
| 702 | ! |
paste(dQuote(available_groups), collapse = ", ") |
| 703 | ! |
), call. = FALSE) |
| 704 |
} |
|
| 705 |
} |
|
| 706 | 29x |
if (!is.null(compare) && !(is.character(compare) && length(compare) == 1L)) |
| 707 | 1x |
stop("qe_edges(): 'compare' as data needs 'weights'; with 'group' it takes a group name.",
|
| 708 | 1x |
call. = FALSE) |
| 709 | 28x |
.check_group(group, "group") |
| 710 | 28x |
.check_group(compare, "compare") |
| 711 | 28x |
.check_group(also, "also") |
| 712 | ||
| 713 |
# Validate unit ID |
|
| 714 | 28x |
if (!is.null(unit) && !unit %in% available_units) {
|
| 715 | ! |
stop(sprintf( |
| 716 | ! |
"qe_edges(): unit = %s not found in model.\nUse qe_units() to see available unit IDs.", |
| 717 | ! |
dQuote(unit) |
| 718 | ! |
), call. = FALSE) |
| 719 |
} |
|
| 720 | ||
| 721 | 28x |
if (!is.null(compare) && !is.null(also)) |
| 722 | ! |
stop("qe_edges(): supply either 'compare' or 'also', not both.", call. = FALSE)
|
| 723 | ||
| 724 | 28x |
if (!is.null(unit) && (!is.null(compare) || !is.null(also))) |
| 725 | ! |
stop("qe_edges(): 'compare' and 'also' cannot be combined with 'unit'.", call. = FALSE)
|
| 726 | ||
| 727 | 28x |
p$graph_opts$group <- group |
| 728 | 28x |
p$graph_opts$unit <- unit |
| 729 | 28x |
p$graph_opts$compare <- compare |
| 730 | 28x |
p$graph_opts$also <- also |
| 731 | 28x |
p$graph_opts[["edge-named"]] <- c(if (!is.null(name)) list(name = name), layer_attrs) |
| 732 | 28x |
p |
| 733 |
} |
|
| 734 | ||
| 735 |
# ── Explicit-network helpers ──────────────────────────────────────────────── |
|
| 736 | ||
| 737 |
# Edge columns of the model: every "A.B" column of the edges frame whose parts |
|
| 738 |
# are both node codes (ONA includes the self-connections "A.A"). |
|
| 739 |
.qe_edge_columns <- function(model) {
|
|
| 740 | 14x |
codes <- vapply(model$nodes$data, function(r) as.character(r[[model$node_id_col]]), "") |
| 741 | 14x |
pairs <- as.vector(outer(codes, codes, paste, sep = ".")) |
| 742 | 14x |
intersect(names(model$edges$types), pairs) |
| 743 |
} |
|
| 744 | ||
| 745 | 14x |
.qe_norm_names <- function(x) gsub(" & ", ".", x, fixed = TRUE)
|
| 746 | ||
| 747 |
# Any rENA-style network input → a numeric vector named by `cols`. |
|
| 748 |
.qe_resolve_weights <- function(x, cols, arg) {
|
|
| 749 | 15x |
if (is.data.frame(x) || is.matrix(x)) {
|
| 750 | 7x |
df <- as.data.frame(x, check.names = FALSE) |
| 751 | 7x |
df <- df[, vapply(df, is.numeric, logical(1)), drop = FALSE] |
| 752 | 7x |
x <- colMeans(as.matrix(df)) |
| 753 | ! |
if (is.null(names(x)) && length(x) == length(cols)) names(x) <- cols |
| 754 |
} |
|
| 755 | 15x |
if (!is.numeric(x)) |
| 756 | ! |
stop(sprintf("qe_edges(): '%s' must be numeric (vector, matrix or data frame).", arg),
|
| 757 | ! |
call. = FALSE) |
| 758 | 15x |
if (is.null(names(x))) {
|
| 759 | 2x |
if (length(x) != length(cols)) |
| 760 | 1x |
stop(sprintf("qe_edges(): unnamed '%s' has %d values; the model has %d edge columns.",
|
| 761 | 1x |
arg, length(x), length(cols)), call. = FALSE) |
| 762 | 1x |
names(x) <- cols |
| 763 |
} |
|
| 764 | 14x |
names(x) <- .qe_norm_names(names(x)) |
| 765 | 14x |
unknown <- setdiff(names(x), cols) |
| 766 | 14x |
if (length(unknown)) |
| 767 | 1x |
stop(sprintf("qe_edges(): '%s' has edges not in the model: %s\nExamples of valid names: %s",
|
| 768 | 1x |
arg, paste(utils::head(unknown, 3), collapse = ", "), |
| 769 | 1x |
paste(utils::head(cols, 3), collapse = ", ")), call. = FALSE) |
| 770 | 13x |
out <- stats::setNames(numeric(length(cols)), cols) |
| 771 | 13x |
out[names(x)] <- as.numeric(x) |
| 772 | 13x |
out |
| 773 |
} |
|
| 774 | ||
| 775 |
# A group's mean network from the model's edges frame (for `compare = "B"`). |
|
| 776 |
.qe_group_network <- function(p, group, cols) {
|
|
| 777 | 1x |
gcol <- p$model$group_col |
| 778 | 1x |
rows <- Filter(function(r) identical(as.character(r[[gcol]]), group), p$model$edges$data) |
| 779 | 1x |
if (!length(rows)) |
| 780 | ! |
stop(sprintf("qe_edges(): compare = %s not found in model.", dQuote(group)), call. = FALSE)
|
| 781 | 1x |
colMeans(do.call(rbind, lapply(rows, function(r) unlist(r[cols])))) |
| 782 |
} |
|
| 783 | ||
| 784 |
.qe_append_network <- function(frame, name, w) {
|
|
| 785 | 12x |
row <- c(list(name = name), as.list(w)) |
| 786 | 12x |
if (is.null(frame)) {
|
| 787 | 10x |
types <- c(list(name = "character"), stats::setNames(as.list(rep("numeric", length(w))), names(w)))
|
| 788 | 10x |
return(list(data = list(row), types = types)) |
| 789 |
} |
|
| 790 | 2x |
frame$data <- c(Filter(function(r) !identical(r$name, name), frame$data), list(row)) |
| 791 | 2x |
frame |
| 792 |
} |
|
| 793 | ||
| 794 |
.qe_layer_attrs <- function(colors, threshold) {
|
|
| 795 | 44x |
if (!is.null(colors) && !(is.character(colors) && length(colors) %in% 1:2)) |
| 796 | 1x |
stop("qe_edges(): colors must be one or two colours.", call. = FALSE)
|
| 797 | 43x |
if (!is.null(threshold) && !(is.numeric(threshold) && length(threshold) %in% 1:2 && |
| 798 | 43x |
all(is.finite(threshold)) && all(threshold >= 0))) |
| 799 | 1x |
stop("qe_edges(): threshold must be c(min, max) or min, non-negative.", call. = FALSE)
|
| 800 | 42x |
c(if (!is.null(colors)) list(colors = paste(colors, collapse = ",")), |
| 801 | 42x |
if (!is.null(threshold)) list(threshold = paste(threshold, collapse = ","))) |
| 802 |
} |
|
| 803 | ||
| 804 |
#' Show or hide unit points |
|
| 805 |
#' |
|
| 806 |
#' @param p A `qe_plot` object. |
|
| 807 |
#' @param show Logical. Default `TRUE`; `FALSE` clears all points and point sets. |
|
| 808 |
#' @param units Unit IDs to draw as a point set (a subset of the model's units). |
|
| 809 |
#' @param points An arbitrary points matrix / data frame / `ena.points` rows |
|
| 810 |
#' (as rENA's `ena.plot.points()` accepts). IDs come from the model's id |
|
| 811 |
#' column when present; dimensions from the model's x / y columns, else the |
|
| 812 |
#' first two numeric columns. |
|
| 813 |
#' @param color One colour, or one per point. Default: each point's group |
|
| 814 |
#' colour, else a palette colour per set. |
|
| 815 |
#' @param shape `"circle"` (default), `"square"`, `"triangle"` or `"diamond"`; |
|
| 816 |
#' one or one per point. rENA's `"triangle-up"` is accepted. |
|
| 817 |
#' @param labels Per-point label text (shown per the point label mode). |
|
| 818 |
#' @param name Point-set name; calls with `units` / `points` add a set, and a |
|
| 819 |
#' repeated name replaces it. Default `"points 1"`, `"points 2"`, …. |
|
| 820 |
#' @param size Optional numeric dot size. Omit for the default (2.5). Larger |
|
| 821 |
#' values draw bigger dots; the size is relative to the code-node size. |
|
| 822 |
#' @param fixed_size Logical. When `TRUE`, unit dots keep a constant on-screen |
|
| 823 |
#' pixel size regardless of data extent, container size, or zoom. Default |
|
| 824 |
#' `FALSE` (dots scale with the coordinate space, like nodes and edges). |
|
| 825 |
#' @return The modified `qe_plot` object. |
|
| 826 |
#' @export |
|
| 827 |
qe_points <- function(p, show = TRUE, units = NULL, points = NULL, |
|
| 828 |
color = NULL, shape = NULL, labels = NULL, name = NULL, |
|
| 829 |
size = NULL, fixed_size = FALSE) {
|
|
| 830 | 14x |
if (!show) {
|
| 831 | 1x |
p$graph_opts$points <- FALSE |
| 832 | 1x |
p$graph_opts[["point-sets"]] <- NULL |
| 833 | 1x |
p$model$pointsets <- NULL |
| 834 | 1x |
return(p) |
| 835 |
} |
|
| 836 | 13x |
if (is.null(units) && is.null(points)) {
|
| 837 |
# All unit points, coloured by group (0.4 behaviour). |
|
| 838 | 5x |
p$graph_opts$points <- TRUE |
| 839 | 5x |
p$graph_opts[["point-size"]] <- size |
| 840 | 5x |
p$graph_opts[["point-fixed-size"]] <- isTRUE(fixed_size) |
| 841 | 5x |
return(p) |
| 842 |
} |
|
| 843 | 8x |
if (!is.null(units) && !is.null(points)) |
| 844 | ! |
stop("qe_points(): supply 'units' or 'points', not both.", call. = FALSE)
|
| 845 | ||
| 846 | 8x |
m <- p$model |
| 847 | 8x |
df <- if (!is.null(units)) {
|
| 848 | 2x |
all <- .qe_frame_df(m$points) |
| 849 | 2x |
bad <- setdiff(units, all[[m$id_col]]) |
| 850 | 2x |
if (length(bad)) |
| 851 | 1x |
stop(sprintf("qe_points(): unit(s) not in model: %s", paste(dQuote(utils::head(bad, 3)), collapse = ", ")),
|
| 852 | 1x |
call. = FALSE) |
| 853 | 1x |
all[match(units, all[[m$id_col]]), , drop = FALSE] |
| 854 | 8x |
} else .qe_point_frame(points, m) |
| 855 | ||
| 856 | 7x |
n <- nrow(df) |
| 857 | 7x |
set <- name %||% sprintf("points %d", length(p$graph_opts[["point-sets"]]) + 1L)
|
| 858 | 7x |
rows <- data.frame(set = rep(set, n), id = as.character(df[[m$id_col]]), stringsAsFactors = FALSE) |
| 859 | 7x |
rows[[m$x_col]] <- df[[m$x_col]] |
| 860 | 7x |
rows[[m$y_col]] <- df[[m$y_col]] |
| 861 | 7x |
if (!is.null(m$group_col) && !is.null(df[[m$group_col]])) |
| 862 | 1x |
rows$group <- as.character(df[[m$group_col]]) |
| 863 | 7x |
per_point <- function(v, arg) {
|
| 864 | 13x |
if (is.null(v)) return(NULL) |
| 865 | 4x |
if (!length(v) %in% c(1L, n)) |
| 866 | 1x |
stop(sprintf("qe_points(): '%s' must have length 1 or %d.", arg, n), call. = FALSE)
|
| 867 | 3x |
rep_len(as.character(v), n) |
| 868 |
} |
|
| 869 | 7x |
rows$color <- per_point(color, "color") |
| 870 | 6x |
rows$shape <- per_point(if (is.null(shape)) NULL else .qe_shape(shape, "qe_points"), "shape") |
| 871 | 5x |
rows$label <- per_point(labels, "labels") |
| 872 | ||
| 873 | 5x |
p$model$pointsets <- .qe_upsert_rows(p$model$pointsets, |
| 874 | 5x |
rows, key = NULL, drop = function(r) identical(r$set, set)) |
| 875 | 5x |
p$graph_opts[["point-sets"]] <- c(Filter(function(s) !identical(s$set, set), |
| 876 | 5x |
p$graph_opts[["point-sets"]]), |
| 877 | 5x |
list(list(set = set, size = size, fixed = isTRUE(fixed_size)))) |
| 878 | 5x |
p |
| 879 |
} |
|
| 880 | ||
| 881 |
# ── Explicit point / group helpers ───────────────────────────────────────── |
|
| 882 | ||
| 883 |
# A QEFrame back to a data.frame (rows may lack some columns). |
|
| 884 |
.qe_frame_df <- function(frame) {
|
|
| 885 | 4x |
if (is.null(frame) || !length(frame$data)) return(data.frame()) |
| 886 | 31x |
cols <- names(frame$types) |
| 887 | 31x |
do.call(rbind, lapply(frame$data, function(r) {
|
| 888 | 116x |
r <- lapply(cols, function(k) if (is.null(r[[k]])) NA else r[[k]]) |
| 889 | 116x |
as.data.frame(stats::setNames(r, cols), stringsAsFactors = FALSE, check.names = FALSE) |
| 890 |
})) |
|
| 891 |
} |
|
| 892 | ||
| 893 |
# Append rows to a QEFrame; rows whose `key` value (or `drop(row)`) matches |
|
| 894 |
# are replaced. Columns are unioned (missing values → NA). |
|
| 895 |
.qe_upsert_rows <- function(frame, rows, key, drop = NULL) {
|
|
| 896 | 11x |
old <- .qe_frame_df(frame) |
| 897 | 11x |
if (nrow(old)) {
|
| 898 | 7x |
keep <- if (!is.null(drop)) !vapply(seq_len(nrow(old)), function(i) drop(as.list(old[i, ])), TRUE) |
| 899 | 7x |
else !(old[[key]] %in% rows[[key]]) |
| 900 | 7x |
old <- old[keep, , drop = FALSE] |
| 901 |
} |
|
| 902 | 11x |
all_cols <- union(names(old), names(rows)) |
| 903 | 11x |
pad <- function(d) { for (k in setdiff(all_cols, names(d))) d[[k]] <- rep(NA, nrow(d)); d[all_cols] }
|
| 904 | 11x |
qe_frame(rbind(if (nrow(old)) pad(old), pad(rows))) |
| 905 |
} |
|
| 906 | ||
| 907 |
# Any rENA-style points input → data.frame with the model's id / x / y (and |
|
| 908 |
# group, when present) columns. Dimensions: the model's x_col / y_col when the |
|
| 909 |
# input has them, else its first two numeric columns (rENA's convention). |
|
| 910 |
.qe_point_frame <- function(x, model) {
|
|
| 911 | 12x |
df <- as.data.frame(x, check.names = FALSE) |
| 912 | 12x |
df <- df[, !duplicated(names(df)), drop = FALSE] |
| 913 | 12x |
num <- names(df)[vapply(df, is.numeric, logical(1))] |
| 914 | 12x |
dims <- if (all(c(model$x_col, model$y_col) %in% num)) c(model$x_col, model$y_col) else num[1:2] |
| 915 | 12x |
if (length(num) < 2 || anyNA(dims)) |
| 916 | ! |
stop("need at least two numeric (dimension) columns in 'points'.", call. = FALSE)
|
| 917 | 12x |
out <- data.frame(id = if (model$id_col %in% names(df)) as.character(df[[model$id_col]]) |
| 918 | 12x |
else if (!is.null(rownames(x))) rownames(x) else as.character(seq_len(nrow(df))), |
| 919 | 12x |
stringsAsFactors = FALSE) |
| 920 | 12x |
names(out) <- model$id_col |
| 921 | 12x |
out[[model$x_col]] <- df[[dims[1]]] |
| 922 | 12x |
out[[model$y_col]] <- df[[dims[2]]] |
| 923 | 12x |
if (!is.null(model$group_col) && model$group_col %in% names(df)) |
| 924 | 3x |
out[[model$group_col]] <- as.character(df[[model$group_col]]) |
| 925 | 12x |
out |
| 926 |
} |
|
| 927 | ||
| 928 |
.qe_shape <- function(shape, fn) {
|
|
| 929 | 3x |
alias <- c(circle = "circle", square = "rect", rect = "rect", triangle = "triangle", |
| 930 | 3x |
`triangle-up` = "triangle", diamond = "diamond") |
| 931 | 3x |
bad <- setdiff(shape, names(alias)) |
| 932 | 3x |
if (length(bad)) |
| 933 | 1x |
stop(sprintf('%s(): shape must be "circle", "square", "triangle" or "diamond".', fn),
|
| 934 | 1x |
call. = FALSE) |
| 935 | 2x |
unname(alias[shape]) |
| 936 |
} |
|
| 937 | ||
| 938 |
#' Show or hide the code nodes |
|
| 939 |
#' |
|
| 940 |
#' By default (`"auto"`) code nodes are drawn only when an edge network is |
|
| 941 |
#' drawn, matching rENA, where nodes are part of `ena.plot.network()`: the |
|
| 942 |
#' `<qe-nodes>` element is emitted only then. Node positions always come from |
|
| 943 |
#' the model and set the plot extent, so the scale does not change. |
|
| 944 |
#' |
|
| 945 |
#' Each node's diameter equals the summed widths of its drawn edges (for |
|
| 946 |
#' directed / ONA models, only the edges directed at the node, plus its |
|
| 947 |
#' self-connection), so node size is proportional to its accumulated |
|
| 948 |
#' connection weight and comparable across plots of the same model. |
|
| 949 |
#' |
|
| 950 |
#' @param p A `qe_plot` object. |
|
| 951 |
#' @param show `"auto"` (default), `"always"`, or `"never"`. `TRUE` / `FALSE` |
|
| 952 |
#' are accepted as `"always"` / `"never"`. |
|
| 953 |
#' @param unconnected What to draw for nodes with no drawn edges: `"dot"` |
|
| 954 |
#' (default, a tiny dot that still marks the code's position) or `"hide"` |
|
| 955 |
#' (omit the node and its label). |
|
| 956 |
#' @param positions Node positions for this plot, replacing the model's (as |
|
| 957 |
#' rENA's `ena.plot.network(node.positions =)`): a data frame / matrix / |
|
| 958 |
#' `rotation$nodes`-like table with a code column (the model's node id |
|
| 959 |
#' column, `code`, or row names) and two numeric columns (the model's x / y |
|
| 960 |
#' columns when present, else the first two numeric ones). A subset of codes |
|
| 961 |
#' moves only those nodes. Edges, node sizes, labels and the plot extent all |
|
| 962 |
#' follow the new positions. |
|
| 963 |
#' @param labels Display text per code: a named character vector |
|
| 964 |
#' (`c(Technical.Constraints = "Tech. constraints")`). The code stays the |
|
| 965 |
#' node's identity (events, edges); only the drawn label changes. `""` |
|
| 966 |
#' draws no label for that code. |
|
| 967 |
#' @param sizes Node diameters in CSS pixels at zoom 1, per code: a named |
|
| 968 |
#' numeric vector (`c(Data = 24)`), in place of the size from the node's |
|
| 969 |
#' edge weights. Codes not listed keep the computed size; unconnected nodes |
|
| 970 |
#' stay a tiny dot (or hidden). |
|
| 971 |
#' @param fixed_size Logical. `TRUE` keeps node diameters at their zoom-1 |
|
| 972 |
#' on-screen size when the plot is zoomed. Default `FALSE` (nodes grow with |
|
| 973 |
#' the zoom). |
|
| 974 |
#' @return The modified `qe_plot` object. |
|
| 975 |
#' @examples |
|
| 976 |
#' \dontrun{
|
|
| 977 |
#' # Means only, but keep the code nodes for orientation |
|
| 978 |
#' qe_plot(set) |> qe_group() |> qe_nodes("always")
|
|
| 979 |
#' } |
|
| 980 |
#' @export |
|
| 981 |
qe_nodes <- function(p, show = c("auto", "always", "never"),
|
|
| 982 |
unconnected = c("dot", "hide"), positions = NULL, labels = NULL,
|
|
| 983 |
sizes = NULL, fixed_size = FALSE) {
|
|
| 984 | 2x |
if (isTRUE(show)) show <- "always" |
| 985 | ! |
if (isFALSE(show)) show <- "never" |
| 986 | 19x |
show <- match.arg(show) |
| 987 | 18x |
unconnected <- match.arg(unconnected) |
| 988 | 17x |
p$graph_opts[["nodes-show"]] <- show |
| 989 | 17x |
p$graph_opts[["nodes-unconnected"]] <- if (unconnected == "hide") "hide" else NULL |
| 990 | 17x |
p$graph_opts[["nodes-fixed-size"]] <- isTRUE(fixed_size) |
| 991 | ||
| 992 | 17x |
if (!is.null(positions) || !is.null(labels) || !is.null(sizes)) {
|
| 993 | 10x |
m <- p$model |
| 994 | 10x |
nodes <- .qe_frame_df(m$nodes) |
| 995 | 10x |
idc <- m$node_id_col |
| 996 | 10x |
codes <- as.character(nodes[[idc]]) |
| 997 | 10x |
check <- function(got, arg) {
|
| 998 | 8x |
bad <- setdiff(got, codes) |
| 999 | 8x |
if (length(bad)) |
| 1000 | 3x |
stop(sprintf("qe_nodes(): '%s' has codes not in the model: %s\nModel codes: %s", arg,
|
| 1001 | 3x |
paste(dQuote(utils::head(bad, 3)), collapse = ", "), |
| 1002 | 3x |
paste(utils::head(codes, 4), collapse = ", ")), call. = FALSE) |
| 1003 |
} |
|
| 1004 | 10x |
if (!is.null(positions)) {
|
| 1005 | 4x |
pos <- as.data.frame(positions, check.names = FALSE) |
| 1006 | 4x |
pc <- if (idc %in% names(pos)) as.character(pos[[idc]]) |
| 1007 | 4x |
else if ("code" %in% names(pos)) as.character(pos$code)
|
| 1008 | 4x |
else if (!is.null(rownames(positions))) rownames(positions) |
| 1009 | 4x |
else stop("qe_nodes(): 'positions' needs a code column or row names.", call. = FALSE)
|
| 1010 | 4x |
num <- names(pos)[vapply(pos, is.numeric, logical(1))] |
| 1011 | 4x |
dims <- if (all(c(m$x_col, m$y_col) %in% num)) c(m$x_col, m$y_col) else num[1:2] |
| 1012 | 4x |
if (length(num) < 2 || anyNA(dims)) |
| 1013 | ! |
stop("qe_nodes(): 'positions' needs two numeric (x, y) columns.", call. = FALSE)
|
| 1014 | 4x |
check(pc, "positions") |
| 1015 | 3x |
i <- match(pc, codes) |
| 1016 | 3x |
nodes[[m$x_col]][i] <- pos[[dims[1]]] |
| 1017 | 3x |
nodes[[m$y_col]][i] <- pos[[dims[2]]] |
| 1018 |
} |
|
| 1019 | 9x |
if (!is.null(labels)) {
|
| 1020 | 3x |
if (!is.character(labels) || is.null(names(labels))) |
| 1021 | 1x |
stop("qe_nodes(): 'labels' must be a named character vector (code = text).", call. = FALSE)
|
| 1022 | 2x |
check(names(labels), "labels") |
| 1023 | 1x |
if (is.null(nodes$label)) nodes$label <- NA_character_ |
| 1024 | 1x |
nodes$label[match(names(labels), codes)] <- unname(labels) |
| 1025 |
} |
|
| 1026 | 7x |
if (!is.null(sizes)) {
|
| 1027 | 3x |
if (!is.numeric(sizes) || is.null(names(sizes)) || any(!is.finite(sizes) | sizes <= 0)) |
| 1028 | 1x |
stop("qe_nodes(): 'sizes' must be a named vector of positive numbers (code = diameter in px).",
|
| 1029 | 1x |
call. = FALSE) |
| 1030 | 2x |
check(names(sizes), "sizes") |
| 1031 | 1x |
if (is.null(nodes$size)) nodes$size <- NA_real_ |
| 1032 | 1x |
nodes$size[match(names(sizes), codes)] <- unname(sizes) |
| 1033 |
} |
|
| 1034 | 5x |
p$model$nodes <- qe_frame(nodes) |
| 1035 |
} |
|
| 1036 | 12x |
p |
| 1037 |
} |
|
| 1038 | ||
| 1039 |
#' Show or hide the axes |
|
| 1040 |
#' |
|
| 1041 |
#' Adds a `<qe-axes>` layer (the x/y axis cross) to the rendered graph. Axis |
|
| 1042 |
#' labels are opt-in: each of `x` and `y` is `FALSE` (no label) by default; |
|
| 1043 |
#' `TRUE` uses the dimension name (e.g. `"SVD1"`) and a string sets custom text. |
|
| 1044 |
#' |
|
| 1045 |
#' @param p A `qe_plot` object. |
|
| 1046 |
#' @param x `TRUE` to label the x-axis with its dimension name, a string for |
|
| 1047 |
#' custom text, or `FALSE` for no x-axis label. Default `FALSE`. |
|
| 1048 |
#' @param y Same as `x`, for the y-axis. Default `FALSE`. |
|
| 1049 |
#' @param show Logical. `FALSE` suppresses the axes entirely. Default `TRUE`. |
|
| 1050 |
#' @param fixed_size Logical. `TRUE` keeps the axis lines and labels at their |
|
| 1051 |
#' zoom-1 on-screen size when the plot is zoomed. Default `FALSE`. |
|
| 1052 |
#' @return The modified `qe_plot` object. |
|
| 1053 |
#' @export |
|
| 1054 |
qe_axes <- function(p, x = FALSE, y = FALSE, show = TRUE, fixed_size = FALSE) {
|
|
| 1055 | 8x |
if (!show) {
|
| 1056 | 1x |
p$graph_opts$axes <- FALSE |
| 1057 | 1x |
return(p) |
| 1058 |
} |
|
| 1059 | 7x |
p$graph_opts$axes <- TRUE |
| 1060 | 7x |
p$graph_opts[["axis-x"]] <- x |
| 1061 | 7x |
p$graph_opts[["axis-y"]] <- y |
| 1062 | 7x |
p$graph_opts[["axes-fixed-size"]] <- isTRUE(fixed_size) |
| 1063 | 7x |
p |
| 1064 |
} |
|
| 1065 | ||
| 1066 |
#' Show or hide trajectory paths |
|
| 1067 |
#' |
|
| 1068 |
#' Adds a `<qe-trajectories>` layer to the rendered graph. QEviz only renders |
|
| 1069 |
#' supplied trajectory rows; accumulation, dooring, model selection, and |
|
| 1070 |
#' inference remain the caller's responsibility. |
|
| 1071 |
#' |
|
| 1072 |
#' @param p A `qe_plot` object. |
|
| 1073 |
#' @param units Optional character vector of unit IDs to show. Omit to show all |
|
| 1074 |
#' units present in the model's `trajectories` frame. |
|
| 1075 |
#' @param smooth Path treatment: `"none"` for observed steps or `"poly"` for |
|
| 1076 |
#' polynomial smoothing. |
|
| 1077 |
#' @param max_degree Upper bound on polynomial degree when `smooth = "poly"`. |
|
| 1078 |
#' With `degree_selection = "loocv_2d"` the actual degree is chosen in |
|
| 1079 |
#' `1..max_degree`; with `"fixed"` this degree is always used. |
|
| 1080 |
#' @param degree_selection Degree selection when `smooth = "poly"`. `"loocv_2d"` |
|
| 1081 |
#' (default) picks the degree by joint 2D leave-one-out cross-validation; |
|
| 1082 |
#' `"fixed"` always uses `max_degree`. Near-origin points are excluded from the |
|
| 1083 |
#' fit (still drawn), matching `ena.plot.trajectory()`. |
|
| 1084 |
#' @param points Logical. Show observed state dots. |
|
| 1085 |
#' @param tips Logical. Show the leading current-state marker. |
|
| 1086 |
#' @param playhead Optional numeric time value. Rows after this value are hidden. |
|
| 1087 |
#' @param line_style `"uniform"` or `"tapered"`. |
|
| 1088 |
#' @param stroke_width Uniform stroke width in display pixels. |
|
| 1089 |
#' @param stroke_width_range Numeric length-2 vector for tapered paths. |
|
| 1090 |
#' @param opacity_range Numeric length-2 vector for tapered paths. |
|
| 1091 |
#' @param show Logical. `FALSE` suppresses trajectory rendering. |
|
| 1092 |
#' |
|
| 1093 |
#' @return The modified `qe_plot` object. |
|
| 1094 |
#' |
|
| 1095 |
#' @export |
|
| 1096 |
qe_trajectories <- function(p, units = NULL, smooth = c("none", "poly"),
|
|
| 1097 |
max_degree = 3L, |
|
| 1098 |
degree_selection = c("loocv_2d", "fixed"),
|
|
| 1099 |
points = TRUE, tips = TRUE, |
|
| 1100 |
playhead = NULL, |
|
| 1101 |
line_style = c("uniform", "tapered"),
|
|
| 1102 |
stroke_width = 2, |
|
| 1103 |
stroke_width_range = c(1, 6), |
|
| 1104 |
opacity_range = c(0.3, 1), |
|
| 1105 |
show = TRUE) {
|
|
| 1106 | 3x |
if (!show) {
|
| 1107 | ! |
p$graph_opts$trajectories <- FALSE |
| 1108 | ! |
return(p) |
| 1109 |
} |
|
| 1110 | ||
| 1111 | 3x |
smooth <- match.arg(smooth) |
| 1112 | 3x |
degree_selection <- match.arg(degree_selection) |
| 1113 | 2x |
line_style <- match.arg(line_style) |
| 1114 | ||
| 1115 | 2x |
if (!is.null(units)) {
|
| 1116 | 2x |
available <- qe_trajectory_units(p) |
| 1117 | 2x |
bad <- units[!units %in% available] |
| 1118 | 2x |
if (length(bad) > 0) {
|
| 1119 | 1x |
stop(sprintf( |
| 1120 | 1x |
"qe_trajectories(): unit(s) not found in model: %s\nAvailable: %s", |
| 1121 | 1x |
paste(dQuote(bad), collapse = ", "), |
| 1122 | 1x |
paste(dQuote(available), collapse = ", ") |
| 1123 | 1x |
), call. = FALSE) |
| 1124 |
} |
|
| 1125 |
} |
|
| 1126 | ||
| 1127 | 1x |
p$graph_opts$trajectories <- TRUE |
| 1128 | 1x |
p$graph_opts[["trajectory-units"]] <- if (is.null(units)) NULL else paste(units, collapse = ",") |
| 1129 | 1x |
p$graph_opts[["trajectory-smooth"]] <- smooth |
| 1130 | 1x |
p$graph_opts[["trajectory-max-degree"]] <- as.integer(max_degree) |
| 1131 | 1x |
p$graph_opts[["trajectory-degree-selection"]] <- degree_selection |
| 1132 | 1x |
p$graph_opts[["trajectory-points"]] <- isTRUE(points) |
| 1133 | 1x |
p$graph_opts[["trajectory-tips"]] <- isTRUE(tips) |
| 1134 | 1x |
p$graph_opts[["trajectory-playhead"]] <- playhead |
| 1135 | 1x |
p$graph_opts[["trajectory-line-style"]] <- line_style |
| 1136 | 1x |
p$graph_opts[["trajectory-stroke-width"]] <- stroke_width |
| 1137 | 1x |
p$graph_opts[["trajectory-stroke-width-range"]] <- paste(stroke_width_range, collapse = ",") |
| 1138 | 1x |
p$graph_opts[["trajectory-opacity-range"]] <- paste(opacity_range, collapse = ",") |
| 1139 | 1x |
p |
| 1140 |
} |
|
| 1141 | ||
| 1142 |
#' Control label visibility |
|
| 1143 |
#' |
|
| 1144 |
#' Only the arguments you supply change; the rest keep their current setting |
|
| 1145 |
#' (so `qe_labels(font_size = 12)` leaves the label modes alone). |
|
| 1146 |
#' |
|
| 1147 |
#' @param p A `qe_plot` object. |
|
| 1148 |
#' @param nodes Label mode for code nodes. One of `"on"`, `"off"`, |
|
| 1149 |
#' `"click"`, `"auto"`. Default `"on"`. |
|
| 1150 |
#' @param means Label mode for group means. Default `"on"`. |
|
| 1151 |
#' @param points Label mode for unit points. Default `"auto"`. |
|
| 1152 |
#' @param font_size Label font size in **pixels** (constant on screen, as in |
|
| 1153 |
#' rENA). Default: scales with the plot. The title is drawn at 1.35×. |
|
| 1154 |
#' @param font_family Label (and title) font family, e.g. `"Georgia"`. |
|
| 1155 |
#' @param font_color Label (and title) colour. Default: each label's own colour |
|
| 1156 |
#' (group colours for means). |
|
| 1157 |
#' @param font_weight Label font weight, e.g. `"bold"` or `600`: one value for |
|
| 1158 |
#' node, mean and point labels, or a named vector for some of them |
|
| 1159 |
#' (`c(nodes = "bold")`). `NULL` clears it. Default: 500. |
|
| 1160 |
#' @return The modified `qe_plot` object. |
|
| 1161 |
#' @export |
|
| 1162 |
qe_labels <- function(p, nodes = "on", means = "on", points = "auto", |
|
| 1163 |
font_size = NULL, font_family = NULL, font_color = NULL, |
|
| 1164 |
font_weight = NULL) {
|
|
| 1165 | 10x |
if (!is.null(font_size) && !(is.numeric(font_size) && length(font_size) == 1L && font_size > 0)) |
| 1166 | 1x |
stop("qe_labels(): font_size must be a positive number of pixels.", call. = FALSE)
|
| 1167 | 9x |
set <- function(key, value, given) if (given) p$graph_opts[[key]] <<- value |
| 1168 |
# A bare qe_labels() still applies the defaults, as before. |
|
| 1169 | 9x |
bare <- missing(nodes) && missing(means) && missing(points) && |
| 1170 | 9x |
missing(font_size) && missing(font_family) && missing(font_color) && |
| 1171 | 9x |
missing(font_weight) |
| 1172 | 9x |
set("label-nodes", nodes, bare || !missing(nodes))
|
| 1173 | 9x |
set("label-means", means, bare || !missing(means))
|
| 1174 | 9x |
set("label-points", points, bare || !missing(points))
|
| 1175 | 9x |
set("label-font-size", font_size, !missing(font_size))
|
| 1176 | 9x |
set("label-font-family", font_family, !missing(font_family))
|
| 1177 | 9x |
set("label-font-color", font_color, !missing(font_color))
|
| 1178 | 9x |
if (!missing(font_weight)) {
|
| 1179 | 4x |
layers <- c("nodes", "means", "points")
|
| 1180 | 4x |
if (is.null(font_weight)) {
|
| 1181 | 1x |
fw <- stats::setNames(vector("list", 3), layers)
|
| 1182 |
} else {
|
|
| 1183 | 3x |
if (!(is.character(font_weight) || is.numeric(font_weight)) || anyNA(font_weight) || |
| 1184 | 3x |
(is.null(names(font_weight)) && length(font_weight) != 1L) || |
| 1185 | 3x |
(!is.null(names(font_weight)) && !all(names(font_weight) %in% layers))) |
| 1186 | 2x |
stop("qe_labels(): font_weight must be one weight (e.g. \"bold\") or a named vector ",
|
| 1187 | 2x |
"for nodes / means / points.", call. = FALSE) |
| 1188 | 1x |
fw <- if (is.null(names(font_weight))) |
| 1189 | 1x |
stats::setNames(as.list(rep(as.character(font_weight), 3)), layers) |
| 1190 | 1x |
else as.list(stats::setNames(as.character(font_weight), names(font_weight))) |
| 1191 |
} |
|
| 1192 | 2x |
for (k in names(fw)) p$graph_opts[[paste0("label-weight-", k)]] <- fw[[k]]
|
| 1193 |
} |
|
| 1194 | 7x |
p |
| 1195 |
} |
|
| 1196 | ||
| 1197 | ||
| 1198 |
# ══ Output functions ═══════════════════════════════════════════════════════════ |
|
| 1199 |
# All three accept a qe_plot object, a raw ena.set, or a plain ModelData list. |
|
| 1200 | ||
| 1201 |
#' Return a qeviz plot as an HTML string |
|
| 1202 |
#' |
|
| 1203 |
#' @param x A `qe_plot` object, a raw rENA / tma / ona set, or a |
|
| 1204 |
#' `ModelData` list from [qe_model_data()] / [qe_extract()]. |
|
| 1205 |
#' @param title `<title>` text. Defaults to the title stored in the |
|
| 1206 |
#' `qe_plot` object when one is supplied. |
|
| 1207 |
#' @param graph_opts Named list of `<qe-graph>` attribute overrides. When `x` |
|
| 1208 |
#' is a `qe_plot` object the stored opts are used as the base; keys supplied |
|
| 1209 |
#' here take precedence. |
|
| 1210 |
#' @param ... Additional arguments forwarded to [qe_extract()] when `x` |
|
| 1211 |
#' is a raw set. |
|
| 1212 |
#' @return A single character string containing a complete HTML document. |
|
| 1213 |
#' @examples |
|
| 1214 |
#' \dontrun{
|
|
| 1215 |
#' writeLines(qe_html(set), "plot.html") |
|
| 1216 |
#' writeLines(qe_html(qe_plot(set) |> qe_group("FirstGame")), "plot.html")
|
|
| 1217 |
#' } |
|
| 1218 |
#' @export |
|
| 1219 |
qe_html <- function(x, title = NULL, graph_opts = list(), ...) {
|
|
| 1220 | 15x |
model <- .to_model(x, ...) |
| 1221 | 15x |
opts <- .resolve_opts(x, graph_opts) |
| 1222 | 15x |
ttl <- .resolve_title(x, title) |
| 1223 | 15x |
json <- jsonlite::toJSON(model, auto_unbox = TRUE, digits = 6, null = "null") |
| 1224 | 15x |
.build_html(json, title = ttl, graph_opts = opts) |
| 1225 |
} |
|
| 1226 | ||
| 1227 |
#' Write a self-contained qeviz HTML file |
|
| 1228 |
#' |
|
| 1229 |
#' @param x A `qe_plot` object, a raw rENA / tma / ona set, or a |
|
| 1230 |
#' `ModelData` list. |
|
| 1231 |
#' @param file Output file path (should end in `.html`). |
|
| 1232 |
#' @param title `<title>` text (defaults to stored title for `qe_plot` objects). |
|
| 1233 |
#' @param graph_opts Named list of `<qe-graph>` attribute overrides. |
|
| 1234 |
#' @param open If `TRUE` (default when interactive), open after writing. |
|
| 1235 |
#' @param ... Additional arguments forwarded to [qe_extract()] when `x` |
|
| 1236 |
#' is a raw set. |
|
| 1237 |
#' @return The normalised `file` path, invisibly. |
|
| 1238 |
#' @examples |
|
| 1239 |
#' \dontrun{
|
|
| 1240 |
#' qe_export_html(set, "ena_plot.html") |
|
| 1241 |
#' qe_export_html(qe_plot(set) |> qe_group("FirstGame"), "fg.html")
|
|
| 1242 |
#' } |
|
| 1243 |
#' @export |
|
| 1244 |
qe_export_html <- function(x, file, title = NULL, graph_opts = list(), |
|
| 1245 |
open = interactive(), ...) {
|
|
| 1246 | 4x |
html <- qe_html(x, title = title, graph_opts = graph_opts, ...) |
| 1247 | 4x |
writeLines(html, file) |
| 1248 | ! |
if (open) .open_viewer(file) |
| 1249 | 4x |
invisible(normalizePath(file)) |
| 1250 |
} |
|
| 1251 | ||
| 1252 |
#' Return a qeviz plot as an embeddable HTML fragment |
|
| 1253 |
#' |
|
| 1254 |
#' Returns a `<div>` with the inlined bundle and a `<qe-visual>` / `<qe-graph>` |
|
| 1255 |
#' pair — no `<html>` wrapper, suitable for R Markdown / Quarto via |
|
| 1256 |
#' `htmltools::HTML()`. |
|
| 1257 |
#' |
|
| 1258 |
#' @param x A `qe_plot` object, a raw rENA / tma / ona set, or a |
|
| 1259 |
#' `ModelData` list. |
|
| 1260 |
#' @param height CSS height of the containing `<div>`. Default `"480px"`. |
|
| 1261 |
#' @param graph_opts Named list of `<qe-graph>` attribute overrides. |
|
| 1262 |
#' @param ... Additional arguments forwarded to [qe_extract()] when `x` |
|
| 1263 |
#' is a raw set. |
|
| 1264 |
#' @return A character string of class `"html"`. |
|
| 1265 |
#' @examples |
|
| 1266 |
#' \dontrun{
|
|
| 1267 |
#' htmltools::HTML(qe_fragment(set)) |
|
| 1268 |
#' htmltools::HTML(qe_fragment(qe_plot(set) |> qe_group("FirstGame")))
|
|
| 1269 |
#' } |
|
| 1270 |
#' @export |
|
| 1271 |
qe_fragment <- function(x, height = "480px", graph_opts = list(), ...) {
|
|
| 1272 | 8x |
model <- .to_model(x, ...) |
| 1273 | 8x |
opts <- .resolve_opts(x, graph_opts) |
| 1274 | 8x |
json <- jsonlite::toJSON(model, auto_unbox = TRUE, digits = 6, null = "null") |
| 1275 | 8x |
bundle <- .bundle_js() |
| 1276 | 8x |
graph_elem <- .build_graph_element(opts) |
| 1277 | 8x |
uid <- paste0("qeviz", as.integer(proc.time()[["elapsed"]] * 1e4) %% 1e9L)
|
| 1278 | ||
| 1279 | 8x |
html <- sprintf( |
| 1280 | 8x |
'<div style="width:100%%;height:%s">\n<script>%s</script>\n<qe-visual id="%s">\n %s\n</qe-visual>\n<script>\ndocument.getElementById("%s").setModelData(%s);\n</script>\n</div>',
|
| 1281 | 8x |
height, bundle, uid, graph_elem, uid, json |
| 1282 |
) |
|
| 1283 | 8x |
structure(html, class = c("html", "character"))
|
| 1284 |
} |
|
| 1285 | ||
| 1286 |
# ── Internal: open a file in RStudio viewer or browser ──────────────────────── |
|
| 1287 | ||
| 1288 |
.open_viewer <- function(path) {
|
|
| 1289 | ! |
path <- normalizePath(path) |
| 1290 | ! |
if (requireNamespace("rstudioapi", quietly = TRUE) &&
|
| 1291 | ! |
rstudioapi::isAvailable() && |
| 1292 | ! |
rstudioapi::hasFun("viewer")) {
|
| 1293 | ! |
rstudioapi::viewer(path) |
| 1294 |
} else {
|
|
| 1295 | ! |
utils::browseURL(paste0("file://", path))
|
| 1296 |
} |
|
| 1297 | ! |
invisible(path) |
| 1298 |
} |
|
| 1299 | ||
| 1300 |
#' The default qeviz colour palette |
|
| 1301 |
#' |
|
| 1302 |
#' Paul Tol's "bright" scheme, the colours qeviz assigns to groups, points |
|
| 1303 |
#' and networks when none are given (the same list as the JavaScript |
|
| 1304 |
#' library's default). Pass a different vector to `qe_plot(palette =)`. |
|
| 1305 |
#' |
|
| 1306 |
#' @return A character vector of eight hex colours. |
|
| 1307 |
#' @examples |
|
| 1308 |
#' qe_palette() |
|
| 1309 |
#' @export |
|
| 1310 |
qe_palette <- function() {
|
|
| 1311 | ! |
c("#4477AA", "#EE6677", "#228833", "#CCBB44",
|
| 1312 | ! |
"#66CCEE", "#AA3377", "#BBBBBB", "#000000") |
| 1313 |
} |
|
| 1314 | ||
| 1315 |
#' Set the axis range of a plot |
|
| 1316 |
#' |
|
| 1317 |
#' Changes the symmetric axis range of an existing plot, as `qe_plot(range =)` |
|
| 1318 |
#' does at creation. |
|
| 1319 |
#' |
|
| 1320 |
#' @param p A `qe_plot` object. |
|
| 1321 |
#' @param range `"network"` (the node extent × 1.2), `"points"` (the unit |
|
| 1322 |
#' points' extent × 1.2), a positive number (the axes run from `-range` to |
|
| 1323 |
#' `range`), or `NULL` for the default. |
|
| 1324 |
#' @return The modified `qe_plot` object. |
|
| 1325 |
#' @examples |
|
| 1326 |
#' \dontrun{
|
|
| 1327 |
#' qe_plot(set) |> qe_range(2) |
|
| 1328 |
#' } |
|
| 1329 |
#' @export |
|
| 1330 |
qe_range <- function(p, range) {
|
|
| 1331 | 8x |
.qe_check_range(range, "qe_range") |
| 1332 | 6x |
p$graph_opts[["range"]] <- range |
| 1333 | 6x |
p |
| 1334 |
} |
|
| 1335 | ||
| 1336 |
.qe_check_range <- function(range, fn) {
|
|
| 1337 | 122x |
if (is.list(range)) |
| 1338 | 2x |
stop(sprintf("%s(): only symmetric ranges are supported: \"network\", \"points\" or a number.", fn),
|
| 1339 | 2x |
call. = FALSE) |
| 1340 | 120x |
if (!is.null(range) && !(identical(range, "network") || identical(range, "points") || |
| 1341 | 120x |
(is.numeric(range) && length(range) == 1L && is.finite(range) && range > 0))) |
| 1342 | 2x |
stop(sprintf("%s(): range must be \"network\", \"points\" or a positive number.", fn), call. = FALSE)
|
| 1343 | 118x |
invisible(range) |
| 1344 |
} |
| 1 |
# widget.R — htmlwidget, knitr and Shiny output |
|
| 2 | ||
| 3 |
#' Render a qeviz plot as an htmlwidget |
|
| 4 |
#' |
|
| 5 |
#' Wraps a [qe_plot()] chain as an htmlwidget, so it renders in the RStudio |
|
| 6 |
#' Viewer, R Markdown / Quarto and Shiny, and can be saved with |
|
| 7 |
#' [htmlwidgets::saveWidget()]. Printing a `qe_plot` uses this. |
|
| 8 |
#' |
|
| 9 |
#' @param p A `qe_plot` object, or a set / `ModelData` list (passed to |
|
| 10 |
#' [qe_plot()] with `...`). |
|
| 11 |
#' @param width,height Widget size — a number (pixels) or a CSS length. |
|
| 12 |
#' Default: the `width` / `height` given to [qe_plot()]. |
|
| 13 |
#' @param elementId Optional element id. |
|
| 14 |
#' @param ... Passed to [qe_plot()] when `p` is not a `qe_plot`. |
|
| 15 |
#' @return An `htmlwidget`. |
|
| 16 |
#' @examples |
|
| 17 |
#' \dontrun{
|
|
| 18 |
#' w <- qe_plot(set) |> qe_edges("FirstGame") |> qe_widget()
|
|
| 19 |
#' htmlwidgets::saveWidget(w, "plot.html") |
|
| 20 |
#' } |
|
| 21 |
#' @export |
|
| 22 |
qe_widget <- function(p, width = NULL, height = NULL, elementId = NULL, ...) {
|
|
| 23 | 1x |
if (!inherits(p, "qe_plot")) p <- qe_plot(p, ...) |
| 24 | 5x |
opts <- p$graph_opts |
| 25 | 5x |
x <- list( |
| 26 | 5x |
model = as.character(jsonlite::toJSON(p$model, auto_unbox = TRUE, digits = 6, null = "null")), |
| 27 | 5x |
graph = .build_graph_element(opts) |
| 28 |
) |
|
| 29 | 5x |
htmlwidgets::createWidget( |
| 30 | 5x |
name = "qeviz", |
| 31 | 5x |
x = x, |
| 32 | 5x |
width = .qe_css_size(width %||% opts$width), |
| 33 | 5x |
height = .qe_css_size(height %||% opts$height), |
| 34 | 5x |
package = "qeviz", |
| 35 | 5x |
elementId = elementId, |
| 36 | 5x |
dependencies = list(.qe_dependency()), |
| 37 | 5x |
sizingPolicy = htmlwidgets::sizingPolicy( |
| 38 | 5x |
defaultWidth = "100%", defaultHeight = 440, |
| 39 | 5x |
viewer.padding = 5, browser.fill = TRUE, |
| 40 | 5x |
knitr.figure = FALSE, knitr.defaultWidth = "100%", knitr.defaultHeight = 440 |
| 41 |
) |
|
| 42 |
) |
|
| 43 |
} |
|
| 44 | ||
| 45 |
#' Shiny bindings for qeviz |
|
| 46 |
#' |
|
| 47 |
#' `qeOutput()` places a plot in the UI; `renderQe()` fills it from an |
|
| 48 |
#' expression returning a `qe_plot` or a [qe_widget()]. |
|
| 49 |
#' |
|
| 50 |
#' @param outputId Shiny output id. |
|
| 51 |
#' @param width,height CSS size of the output. |
|
| 52 |
#' @param expr Expression returning a `qe_plot` or `qe_widget()`. |
|
| 53 |
#' @param env Environment in which to evaluate `expr`. |
|
| 54 |
#' @param quoted Is `expr` already quoted? |
|
| 55 |
#' @examples |
|
| 56 |
#' \dontrun{
|
|
| 57 |
#' ui <- shiny::fluidPage( |
|
| 58 |
#' shiny::selectInput("g", "Group", c("FirstGame", "SecondGame")),
|
|
| 59 |
#' qeOutput("plot")
|
|
| 60 |
#' ) |
|
| 61 |
#' server <- function(input, output) {
|
|
| 62 |
#' output$plot <- renderQe(qe_plot(set) |> qe_edges(input$g) |> qe_group(input$g)) |
|
| 63 |
#' } |
|
| 64 |
#' shiny::shinyApp(ui, server) |
|
| 65 |
#' } |
|
| 66 |
#' @export |
|
| 67 |
qeOutput <- function(outputId, width = "100%", height = "440px") {
|
|
| 68 | 1x |
htmlwidgets::shinyWidgetOutput(outputId, "qeviz", width, height, package = "qeviz") |
| 69 |
} |
|
| 70 | ||
| 71 |
#' @rdname qeOutput |
|
| 72 |
#' @export |
|
| 73 |
renderQe <- function(expr, env = parent.frame(), quoted = FALSE) {
|
|
| 74 | 1x |
if (!quoted) expr <- substitute(expr) |
| 75 |
# Accept a qe_plot as well as a widget. |
|
| 76 | 1x |
expr <- bquote({
|
| 77 | ! |
.qe_val <- .(expr) |
| 78 | ! |
if (inherits(.qe_val, "qe_plot")) qeviz::qe_widget(.qe_val) else .qe_val |
| 79 |
}) |
|
| 80 | 1x |
htmlwidgets::shinyRenderWidget(expr, qeOutput, env, quoted = TRUE) |
| 81 |
} |
|
| 82 | ||
| 83 |
#' Render a qe_plot object in the viewer |
|
| 84 |
#' |
|
| 85 |
#' Called when a `qe_plot` is returned at the top level: shows it as a |
|
| 86 |
#' [qe_widget()] in the RStudio Viewer or the browser. |
|
| 87 |
#' |
|
| 88 |
#' @param x A `qe_plot` object. |
|
| 89 |
#' @param ... Ignored. |
|
| 90 |
#' @export |
|
| 91 |
print.qe_plot <- function(x, ...) {
|
|
| 92 | ! |
print(qe_widget(x)) |
| 93 | ! |
invisible(x) |
| 94 |
} |
|
| 95 | ||
| 96 |
# Registered in .onLoad so knitr stays a suggested package. |
|
| 97 |
knit_print.qe_plot <- function(x, ..., options = NULL) {
|
|
| 98 | 1x |
knitr::knit_print(qe_widget(x), ..., options = options) |
| 99 |
} |
|
| 100 | ||
| 101 |
.onLoad <- function(libname, pkgname) {
|
|
| 102 | ! |
if (requireNamespace("knitr", quietly = TRUE))
|
| 103 | ! |
registerS3method("knit_print", "qe_plot", knit_print.qe_plot, envir = asNamespace("knitr"))
|
| 104 | ! |
invisible() |
| 105 |
} |
|
| 106 | ||
| 107 |
.qe_dependency <- function() {
|
|
| 108 | 5x |
htmltools::htmlDependency( |
| 109 | 5x |
name = "qeviz", |
| 110 | 5x |
version = as.character(utils::packageVersion("qeviz")),
|
| 111 | 5x |
src = c(file = system.file("htmlwidgets", "lib", "qeviz", package = "qeviz")),
|
| 112 | 5x |
script = "qeviz.umd.js" |
| 113 |
) |
|
| 114 |
} |
|
| 115 | ||
| 116 |
# "440" -> 440 (pixels); CSS lengths ("100%", "30em") pass through.
|
|
| 117 |
.qe_css_size <- function(v) {
|
|
| 118 | ! |
if (is.null(v)) return(NULL) |
| 119 | 4x |
if (is.character(v) && grepl("^[0-9.]+$", v)) as.numeric(v) else v
|
| 120 |
} |
| 1 |
# frames.R — low-level helpers for building QEFrame structures |
|
| 2 |
# |
|
| 3 |
# A QEFrame is the wire format qeviz expects for every data table: |
|
| 4 |
# { data: [ {col: val, ...}, ... ], types: { col: "character"|"numeric"|"integer"|"logical" } }
|
|
| 5 | ||
| 6 |
# ── Internal helpers ─────────────────────────────────────────────────────────── |
|
| 7 | ||
| 8 |
#' Convert a data.frame to a QEFrame list |
|
| 9 |
#' |
|
| 10 |
#' Serialises a data.frame into the `{ data, types }` structure expected by
|
|
| 11 |
#' qeviz's `ModelData` interface. Factors are coerced to character. |
|
| 12 |
#' |
|
| 13 |
#' @param df A `data.frame` (or object coercible via `as.data.frame()`). |
|
| 14 |
#' @return A named list with elements `data` (list of row lists) and `types` |
|
| 15 |
#' (named character vector of column types). |
|
| 16 |
#' @keywords internal |
|
| 17 |
qe_frame <- function(df) {
|
|
| 18 | 115x |
df <- as.data.frame(df) |
| 19 | 115x |
types <- vapply(df, function(col) {
|
| 20 | 182x |
if (is.character(col) || is.factor(col)) "character" |
| 21 | 6x |
else if (is.logical(col)) "logical" |
| 22 | 5x |
else if (is.integer(col)) "integer" |
| 23 | 448x |
else "numeric" |
| 24 | 115x |
}, character(1L)) |
| 25 | 115x |
rows <- lapply(seq_len(nrow(df)), function(i) {
|
| 26 | 730x |
r <- as.list(df[i, , drop = FALSE]) |
| 27 | 730x |
lapply(r, function(v) if (is.factor(v)) as.character(v) else v) |
| 28 |
}) |
|
| 29 | 115x |
list(data = rows, types = as.list(types)) |
| 30 |
} |
|
| 31 | ||
| 32 |
#' Return the names of the first two numeric columns |
|
| 33 |
#' |
|
| 34 |
#' Used to locate the rotated dimension axes (e.g. `SVD1`, `SVD2`) in a |
|
| 35 |
#' nodes or points data.frame without hardcoding column names. |
|
| 36 |
#' |
|
| 37 |
#' @param df A `data.frame`. |
|
| 38 |
#' @return Character vector of length 2. |
|
| 39 |
#' @keywords internal |
|
| 40 |
find_dims <- function(df) {
|
|
| 41 | 12x |
nm <- names(df)[vapply(df, is.numeric, logical(1L))] |
| 42 | 12x |
if (length(nm) < 2L) |
| 43 | 1x |
stop("Expected at least two numeric dimension columns in data.frame.")
|
| 44 | 11x |
nm[1:2] |
| 45 |
} |
|
| 46 | ||
| 47 |
#' Compute per-group means and 95% CI bounds |
|
| 48 |
#' |
|
| 49 |
#' For each group, computes the mean x/y position and a rectangular 95% |
|
| 50 |
#' confidence interval using `t(df = n-1, 0.975) * SE` on each axis |
|
| 51 |
#' independently. This matches the CI convention used by rENA / Web ENA. |
|
| 52 |
#' |
|
| 53 |
#' @param pts A `data.frame` with at least the columns named by `x_col`, |
|
| 54 |
#' `y_col`, and `group_col`. |
|
| 55 |
#' @param x_col Name of the x-coordinate column. |
|
| 56 |
#' @param y_col Name of the y-coordinate column. |
|
| 57 |
#' @param group_col Name of the grouping column. |
|
| 58 |
#' @param conf_level Confidence level for the t interval. Default 0.95. |
|
| 59 |
#' @param outlier Also add `<dim>.olow` / `<dim>.ohigh` outlier bounds |
|
| 60 |
#' (Q1 − 1.5·IQR, Q3 + 1.5·IQR). Default `FALSE`. |
|
| 61 |
#' @return A `data.frame` with the group column, `x_col`, `y_col`, and |
|
| 62 |
#' `<x_col>.low`, `<x_col>.high`, `<y_col>.low`, `<y_col>.high` (the bound |
|
| 63 |
#' names qeviz looks up from the model's dimension names). |
|
| 64 |
#' @keywords internal |
|
| 65 |
group_summary <- function(pts, x_col, y_col, group_col, conf_level = 0.95, |
|
| 66 |
outlier = FALSE) {
|
|
| 67 | 31x |
groups <- sort(unique(pts[[group_col]])) |
| 68 | 31x |
do.call(rbind, lapply(groups, function(g) {
|
| 69 | 56x |
sub <- pts[pts[[group_col]] == g, ] |
| 70 | 56x |
n <- nrow(sub) |
| 71 | 56x |
t_v <- stats::qt((1 + conf_level) / 2, df = max(1L, n - 1L)) |
| 72 | 56x |
x <- sub[[x_col]]; y <- sub[[y_col]] |
| 73 | 56x |
mx <- mean(x, na.rm = TRUE); my <- mean(y, na.rm = TRUE) |
| 74 | 56x |
se_x <- stats::sd(x, na.rm = TRUE) / sqrt(n) |
| 75 | 56x |
se_y <- stats::sd(y, na.rm = TRUE) / sqrt(n) |
| 76 | 56x |
row <- stats::setNames( |
| 77 | 56x |
data.frame(g, mx, my, |
| 78 | 56x |
mx - t_v * se_x, mx + t_v * se_x, |
| 79 | 56x |
my - t_v * se_y, my + t_v * se_y, |
| 80 | 56x |
stringsAsFactors = FALSE), |
| 81 | 56x |
c(group_col, x_col, y_col, |
| 82 | 56x |
paste0(x_col, c(".low", ".high")), paste0(y_col, c(".low", ".high")))
|
| 83 |
) |
|
| 84 | 56x |
if (isTRUE(outlier)) {
|
| 85 |
# Q1 − 1.5·IQR … Q3 + 1.5·IQR per dimension. |
|
| 86 | 6x |
fence <- function(v) { q <- stats::quantile(v, c(.25, .75), na.rm = TRUE, names = FALSE)
|
| 87 | 6x |
c(q[1] - 1.5 * diff(q), q[2] + 1.5 * diff(q)) } |
| 88 | 3x |
fx <- fence(x); fy <- fence(y) |
| 89 | 3x |
row[[paste0(x_col, ".olow")]] <- fx[1]; row[[paste0(x_col, ".ohigh")]] <- fx[2] |
| 90 | 3x |
row[[paste0(y_col, ".olow")]] <- fy[1]; row[[paste0(y_col, ".ohigh")]] <- fy[2] |
| 91 |
} |
|
| 92 | 56x |
row |
| 93 |
})) |
|
| 94 |
} |
| 1 |
# model.R — build ModelData structures from data.frames or rENA/tma set objects |
|
| 2 | ||
| 3 |
#' Build a qeviz ModelData list from data.frames |
|
| 4 |
#' |
|
| 5 |
#' Assembles the `ModelData` structure consumed by `<qe-visual>` from |
|
| 6 |
#' pre-prepared data.frames. All data.frames are converted to QEFrames |
|
| 7 |
#' (see [qe_frame()]). |
|
| 8 |
#' |
|
| 9 |
#' @param nodes `data.frame` of code-node positions. Must contain columns |
|
| 10 |
#' `node_id_col`, `x_col`, `y_col`. |
|
| 11 |
#' @param edges `data.frame` of edge weights. Must contain `id_col` plus |
|
| 12 |
#' one column per edge pair (e.g. `Data.Collaboration`). |
|
| 13 |
#' @param points `data.frame` of unit positions. Must contain `id_col`, |
|
| 14 |
#' `group_col`, `x_col`, `y_col`. |
|
| 15 |
#' @param trajectories Optional ordered observations for one or more units. |
|
| 16 |
#' Must contain `id_col`, `x_col`, `y_col`, and ideally `time`, `RowID`, or |
|
| 17 |
#' `ActivityNumber` for playhead ordering. |
|
| 18 |
#' @param groups `data.frame` of group summary statistics as returned by |
|
| 19 |
#' [group_summary()], or `NULL` to compute automatically from `points`. |
|
| 20 |
#' @param directed Logical. `TRUE` for ONA (ordered/directed) models. |
|
| 21 |
#' @param id_col Name of the unit-ID column in `edges` and `points`. |
|
| 22 |
#' @param node_id_col Name of the code-ID column in `nodes`. |
|
| 23 |
#' @param x_col Name of the x-coordinate column. |
|
| 24 |
#' @param y_col Name of the y-coordinate column. |
|
| 25 |
#' @param group_col Name of the group column in `points`. |
|
| 26 |
#' |
|
| 27 |
#' @return A named list suitable for serialisation with [jsonlite::toJSON()] |
|
| 28 |
#' and passing to `qe_export_html()` or `qe_plot()`. |
|
| 29 |
#' |
|
| 30 |
#' @examples |
|
| 31 |
#' \dontrun{
|
|
| 32 |
#' model <- qe_model_data(nodes_df, edges_df, points_df, directed = FALSE) |
|
| 33 |
#' qe_plot(model) |
|
| 34 |
#' } |
|
| 35 |
#' |
|
| 36 |
#' @export |
|
| 37 |
qe_model_data <- function( |
|
| 38 |
nodes, |
|
| 39 |
edges, |
|
| 40 |
points = NULL, |
|
| 41 |
trajectories = NULL, |
|
| 42 |
groups = NULL, |
|
| 43 |
directed = FALSE, |
|
| 44 |
id_col = "ENA_UNIT", |
|
| 45 |
node_id_col = "code", |
|
| 46 |
x_col = "x", |
|
| 47 |
y_col = "y", |
|
| 48 |
group_col = "Condition" |
|
| 49 |
) {
|
|
| 50 | 26x |
if (!is.null(points) && is.null(groups) && !is.null(group_col)) {
|
| 51 | 9x |
groups <- group_summary(as.data.frame(points), x_col, y_col, group_col) |
| 52 |
} |
|
| 53 | 26x |
result <- list( |
| 54 | 26x |
directed = directed, |
| 55 | 26x |
updated = as.numeric(Sys.time()) * 1000L, |
| 56 | 26x |
id_col = id_col, |
| 57 | 26x |
node_id_col = node_id_col, |
| 58 | 26x |
x_col = x_col, |
| 59 | 26x |
y_col = y_col, |
| 60 | 26x |
group_col = group_col, |
| 61 | 26x |
nodes = qe_frame(nodes), |
| 62 | 26x |
edges = qe_frame(edges) |
| 63 |
) |
|
| 64 | 20x |
if (!is.null(points)) result$points <- qe_frame(points) |
| 65 | 3x |
if (!is.null(trajectories)) result$trajectories <- qe_frame(trajectories) |
| 66 | 18x |
if (!is.null(groups)) result$groups <- qe_frame(groups) |
| 67 | 26x |
result |
| 68 |
} |
|
| 69 | ||
| 70 |
#' Extract a qeviz ModelData list from an rENA / tma model object |
|
| 71 |
#' |
|
| 72 |
#' Reads nodes, points, edges, and group membership from a set object |
|
| 73 |
#' produced by `rENA::model()` (tma pipeline) and returns a `ModelData` |
|
| 74 |
#' list ready for rendering. |
|
| 75 |
#' |
|
| 76 |
#' The set object must expose: |
|
| 77 |
#' * `set$rotation$nodes` — code positions data.frame with a `code` column |
|
| 78 |
#' * `set$points` — unit positions data.frame with `ENA_UNIT`, |
|
| 79 |
#' `Condition`, and rotated-dimension columns |
|
| 80 |
#' * `set$line.weights` — edge-weight columns (one per code pair) |
|
| 81 |
#' * `set$meta.data` — unit metadata including `ENA_UNIT`, `Condition` |
|
| 82 |
#' |
|
| 83 |
#' Edge column names are normalised: `" & "` separators are replaced with |
|
| 84 |
#' `"."` so qeviz's edge parser can resolve them (e.g. `"Data & Collab"` |
|
| 85 |
#' becomes `"Data.Collab"`). |
|
| 86 |
#' |
|
| 87 |
#' @param set A model set object from `rENA::model()` or `ona::model()`. |
|
| 88 |
#' @param directed Logical, or `NULL` (default). When `NULL`, directionality |
|
| 89 |
#' is detected automatically: sets with class `"ena.ordered.set"` (ONA) are |
|
| 90 |
#' treated as directed; standard ENA sets are treated as undirected. Pass |
|
| 91 |
#' `TRUE` or `FALSE` explicitly only if you need to override the default. |
|
| 92 |
#' @param id_col Unit-ID column name in the set's meta/points frames. |
|
| 93 |
#' @param node_id_col Code-ID column name in the nodes frame. |
|
| 94 |
#' @param group_col Group column name. |
|
| 95 |
#' @param dims The two dimensions to plot: names (`c("SVD1", "SVD3")`) or
|
|
| 96 |
#' indices among the numeric node columns. Default: the first two. |
|
| 97 |
#' |
|
| 98 |
#' @return A `ModelData` list (see [qe_model_data()]). |
|
| 99 |
#' |
|
| 100 |
#' @examples |
|
| 101 |
#' \dontrun{
|
|
| 102 |
#' library(tma); library(rENA) |
|
| 103 |
#' data(RS.data) |
|
| 104 |
#' result <- tma::accumulate(tensor, codes = codes, |
|
| 105 |
#' context_model = ctx, ordered = FALSE) |
|
| 106 |
#' ena_set <- rENA::model(result) |
|
| 107 |
#' ena_model <- qe_extract(ena_set, directed = FALSE) |
|
| 108 |
#' qe_plot(ena_model) |
|
| 109 |
#' } |
|
| 110 |
#' |
|
| 111 |
#' @export |
|
| 112 |
qe_extract <- function( |
|
| 113 |
set, |
|
| 114 |
directed = NULL, |
|
| 115 |
id_col = "ENA_UNIT", |
|
| 116 |
node_id_col = "code", |
|
| 117 |
group_col = "Condition", |
|
| 118 |
dims = NULL |
|
| 119 |
) {
|
|
| 120 |
# ── Directionality ───────────────────────────────────────────────────────── |
|
| 121 |
# Ordered (ONA) sets carry class "ena.ordered.set", which means the |
|
| 122 |
# line.weights matrix is asymmetric (A→B and B→A are distinct columns). |
|
| 123 |
# Auto-detect from the set class so callers don't have to specify it. |
|
| 124 |
# An explicit directed = TRUE/FALSE overrides the auto-detection. |
|
| 125 | 13x |
if (is.null(directed)) {
|
| 126 | 10x |
directed <- inherits(set, "ena.ordered.set") |
| 127 |
} |
|
| 128 | ||
| 129 |
# ── Nodes ────────────────────────────────────────────────────────────────── |
|
| 130 | 13x |
nodes_raw <- as.data.frame(set$rotation$nodes) |
| 131 | 13x |
dims <- .qe_pick_dims(nodes_raw, dims) |
| 132 |
# Keep the set's dimension names (e.g. SVD1 / SVD2): qeviz uses x_col / y_col |
|
| 133 |
# as the axis-label text, so renaming to x / y would label the axes "x" / "y". |
|
| 134 | 11x |
nodes_df <- nodes_raw[, c(node_id_col, dims), drop = FALSE] |
| 135 | ||
| 136 |
# ── Points ───────────────────────────────────────────────────────────────── |
|
| 137 | 11x |
pts_raw <- as.data.frame(set$points) |
| 138 | 11x |
points_df <- pts_raw[, c(id_col, group_col, dims), drop = FALSE] |
| 139 | ||
| 140 |
# ── Edges ────────────────────────────────────────────────────────────────── |
|
| 141 | 11x |
meta_df <- as.data.frame(set$meta.data)[, c(id_col, group_col), drop = FALSE] |
| 142 | 11x |
edges_raw <- as.data.frame(set$line.weights) |
| 143 | 11x |
edges_df <- cbind(meta_df, edges_raw) |
| 144 |
# Normalise separator: rENA uses " & ", qeviz expects "." |
|
| 145 | 11x |
names(edges_df) <- gsub(" & ", ".", names(edges_df), fixed = TRUE)
|
| 146 | ||
| 147 |
# ── Groups (means + 95% CI) ──────────────────────────────────────────────── |
|
| 148 |
# No group column (group_col = NULL): points and networks only, no means. |
|
| 149 | 11x |
groups_df <- if (is.null(group_col)) NULL |
| 150 | 11x |
else group_summary(points_df, dims[1], dims[2], group_col) |
| 151 | ||
| 152 | 11x |
qe_model_data( |
| 153 | 11x |
nodes = nodes_df, |
| 154 | 11x |
edges = edges_df, |
| 155 | 11x |
points = points_df, |
| 156 | 11x |
groups = groups_df, |
| 157 | 11x |
directed = directed, |
| 158 | 11x |
id_col = id_col, |
| 159 | 11x |
node_id_col = node_id_col, |
| 160 | 11x |
x_col = dims[1], |
| 161 | 11x |
y_col = dims[2], |
| 162 | 11x |
group_col = group_col |
| 163 |
) |
|
| 164 |
} |
|
| 165 | ||
| 166 |
#' List the group names in a model |
|
| 167 |
#' |
|
| 168 |
#' Returns the unique group names present in a `ModelData` list or `qe_plot` |
|
| 169 |
#' object. Useful when a dataset has more than two groups and you want to |
|
| 170 |
#' iterate over them or validate a group name before passing it to |
|
| 171 |
#' [qe_group()]. |
|
| 172 |
#' |
|
| 173 |
#' @param x A `qe_plot` object or a `ModelData` list from [qe_model_data()] / |
|
| 174 |
#' [qe_extract()]. |
|
| 175 |
#' |
|
| 176 |
#' @return A character vector of group names, in the order they appear in the |
|
| 177 |
#' model's group summary table. |
|
| 178 |
#' |
|
| 179 |
#' @examples |
|
| 180 |
#' \dontrun{
|
|
| 181 |
#' model <- qe_extract(set) |
|
| 182 |
#' qe_groups(model) |
|
| 183 |
#' #> [1] "FirstGame" "SecondGame" |
|
| 184 |
#' |
|
| 185 |
#' # Useful for iterating over all groups: |
|
| 186 |
#' lapply(qe_groups(model), function(g) {
|
|
| 187 |
#' qe_plot(model) |> qe_group(g) |> qe_export_html(paste0(g, ".html")) |
|
| 188 |
#' }) |
|
| 189 |
#' } |
|
| 190 |
#' |
|
| 191 |
#' @export |
|
| 192 |
qe_groups <- function(x) {
|
|
| 193 | 40x |
model <- if (inherits(x, "qe_plot")) x$model |
| 194 | 40x |
else if (inherits(x, "ena.set")) qe_extract(x) |
| 195 | 40x |
else x |
| 196 | 40x |
gcol <- .qe_group_key(model) |
| 197 | 40x |
vapply(model$groups$data, function(row) {
|
| 198 | 78x |
v <- row[[gcol]] |
| 199 | 78x |
if (is.null(v)) NA_character_ else as.character(v) |
| 200 | 40x |
}, character(1L)) |
| 201 |
} |
|
| 202 | ||
| 203 |
#' List the unit IDs in a model |
|
| 204 |
#' |
|
| 205 |
#' Returns the unit IDs present in a `ModelData` list or `qe_plot` object. |
|
| 206 |
#' Unit IDs are the values in the model's `id_col` column (default |
|
| 207 |
#' `"ENA_UNIT"`), typically in compound form `"Group::Name"` as produced by |
|
| 208 |
#' rENA / tma. Pass any of these strings to [qe_edges()] as the `unit` |
|
| 209 |
#' argument to plot an individual unit's edge network. |
|
| 210 |
#' |
|
| 211 |
#' @param x A `qe_plot` object or a `ModelData` list from [qe_model_data()] / |
|
| 212 |
#' [qe_extract()]. |
|
| 213 |
#' |
|
| 214 |
#' @return A character vector of unit IDs, in the order they appear in the |
|
| 215 |
#' model's points table. Returns `character(0)` if the model has no points |
|
| 216 |
#' frame. |
|
| 217 |
#' |
|
| 218 |
#' @examples |
|
| 219 |
#' \dontrun{
|
|
| 220 |
#' model <- qe_extract(set) |
|
| 221 |
#' qe_units(model) |
|
| 222 |
#' #> [1] "FirstGame::steven z" "FirstGame::akash v" |
|
| 223 |
#' #> [3] "SecondGame::steven z" ... |
|
| 224 |
#' |
|
| 225 |
#' # Plot one unit's edge network alongside both group means: |
|
| 226 |
#' qe_plot(set) |> |
|
| 227 |
#' qe_group() |> |
|
| 228 |
#' qe_points() |> |
|
| 229 |
#' qe_edges(unit = "FirstGame::steven z") |
|
| 230 |
#' } |
|
| 231 |
#' |
|
| 232 |
#' @export |
|
| 233 |
qe_units <- function(x) {
|
|
| 234 | 29x |
model <- if (inherits(x, "qe_plot")) x$model |
| 235 | 29x |
else if (inherits(x, "ena.set")) qe_extract(x) |
| 236 | 29x |
else x |
| 237 | 29x |
id_col <- model$id_col %||% "ENA_UNIT" |
| 238 | ! |
if (is.null(model$points)) return(character(0L)) |
| 239 | 29x |
vapply(model$points$data, function(row) {
|
| 240 | 232x |
v <- row[[id_col]] |
| 241 | 232x |
if (is.null(v)) NA_character_ else as.character(v) |
| 242 | 29x |
}, character(1L)) |
| 243 |
} |
|
| 244 | ||
| 245 |
#' List the trajectory unit IDs in a model |
|
| 246 |
#' |
|
| 247 |
#' Returns the unit IDs present in the model's `trajectories` frame. If no |
|
| 248 |
#' separate trajectories frame is present, falls back to [qe_units()] because |
|
| 249 |
#' qeviz can use point rows as trajectory states. |
|
| 250 |
#' |
|
| 251 |
#' @param x A `qe_plot` object or a `ModelData` list from [qe_model_data()] / |
|
| 252 |
#' [qe_extract()]. |
|
| 253 |
#' |
|
| 254 |
#' @return A character vector of trajectory unit IDs. |
|
| 255 |
#' |
|
| 256 |
#' @export |
|
| 257 |
qe_trajectory_units <- function(x) {
|
|
| 258 | 4x |
model <- if (inherits(x, "qe_plot")) x$model |
| 259 | 4x |
else if (inherits(x, "ena.set")) qe_extract(x) |
| 260 | 4x |
else x |
| 261 | 4x |
id_col <- model$id_col %||% "ENA_UNIT" |
| 262 | 4x |
frame <- model$trajectories %||% model$points |
| 263 | ! |
if (is.null(frame)) return(character(0L)) |
| 264 | 4x |
unique(vapply(frame$data, function(row) {
|
| 265 | 80x |
v <- row[[id_col]] |
| 266 | 80x |
if (is.null(v)) NA_character_ else as.character(v) |
| 267 | 4x |
}, character(1L))) |
| 268 |
} |
|
| 269 | ||
| 270 |
# Two dimension columns: `dims` as names or indices among the numeric columns, |
|
| 271 |
# else the first two numeric columns. |
|
| 272 |
.qe_pick_dims <- function(df, dims = NULL) {
|
|
| 273 | 13x |
num <- names(df)[vapply(df, is.numeric, logical(1L))] |
| 274 | 9x |
if (is.null(dims)) return(find_dims(df)) |
| 275 | 1x |
if (length(dims) != 2L) stop("dims must name or index exactly two dimensions.", call. = FALSE)
|
| 276 | 3x |
out <- if (is.numeric(dims)) num[dims] else as.character(dims) |
| 277 | 3x |
bad <- setdiff(out, num) |
| 278 | 3x |
if (anyNA(out) || length(bad)) |
| 279 | 1x |
stop(sprintf("dims not found among the dimensions: %s\nAvailable: %s",
|
| 280 | 1x |
paste(dQuote(if (anyNA(out)) dims else bad), collapse = ", "), |
| 281 | 1x |
paste(utils::head(num, 6), collapse = ", ")), call. = FALSE) |
| 282 | 2x |
out |
| 283 |
} |
|
| 284 | ||
| 285 |
# Column naming the group in the groups frame: the model's group column, else |
|
| 286 |
# "group" (a model extracted with group_col = NULL, holding only explicit |
|
| 287 |
# means; the renderer falls back to "group" the same way). |
|
| 288 | 45x |
.qe_group_key <- function(model) model$group_col %||% "group" |