beatrina 0.8.7 → 0.9.83
This diff represents the content of publicly available package versions that have been released to one of the supported registries. The information contained in this diff is provided for informational purposes only and reflects changes between package versions as they appear in their respective public registries.
- package/NOTICES +1 -1
- package/README.md +6 -0
- package/beatrina_V0.9.83.html +1903 -0
- package/beatrina_V0.9.83.html.inputs.json +1 -0
- package/bin/beatrina.mjs +152 -24
- package/bin/browser.mjs +31 -0
- package/bin/cli.mjs +64 -5
- package/bin/doctor-rows.mjs +31 -0
- package/bin/failsafe.mjs +8 -3
- package/bin/finder.mjs +74 -0
- package/bin/lsquery.swift +55 -0
- package/bin/pages.mjs +81 -0
- package/bin/python-setup.mjs +207 -0
- package/bin/runtime-dirs.mjs +27 -0
- package/bin/sessions.mjs +30 -10
- package/bin/shortcut.mjs +250 -42
- package/bin/update-check.mjs +2 -2
- package/build-info.json +1 -1
- package/engines/js/worker.mjs +6 -3
- package/engines/python/adapter.py +14 -13
- package/engines/python/analyze.py +4 -2
- package/engines/python/bootstrap.py +32 -31
- package/engines/python/debugger.py +10 -6
- package/engines/python/engine.json +1 -1
- package/engines/python/handoff.py +4 -2
- package/engines/python/worker.py +39 -10
- package/engines/r/engine.json +1 -1
- package/engines/r/handoff.R +4 -3
- package/failsafe/ai-policy.R +16 -16
- package/failsafe/ai-store.R +6 -6
- package/failsafe/cite.R +11 -11
- package/failsafe/journal.R +11 -11
- package/failsafe/plugins.R +27 -27
- package/failsafe/serve.R +241 -241
- package/host/ai-authority.mjs +55 -0
- package/host/ai-policy.mjs +48 -26
- package/host/bundle.mjs +194 -0
- package/host/deployment.mjs +25 -18
- package/host/engine-js.mjs +12 -17
- package/host/engine-pool.mjs +48 -6
- package/host/engine-python.mjs +80 -31
- package/host/engine-r.mjs +20 -21
- package/host/engine-stdio.mjs +35 -10
- package/host/env-names.mjs +148 -0
- package/host/gateway-token.mjs +51 -0
- package/host/journal-store.mjs +29 -12
- package/host/main.mjs +193 -77
- package/host/payload.mjs +131 -0
- package/host/planes/README.md +1 -1
- package/host/planes/ai-store.mjs +6 -5
- package/host/planes/ai.mjs +49 -29
- package/host/planes/analyze.mjs +6 -5
- package/host/planes/bundle.mjs +344 -0
- package/host/planes/choose.mjs +415 -0
- package/host/planes/cite.mjs +18 -17
- package/host/planes/expect-term.mjs +102 -0
- package/host/planes/files.mjs +0 -0
- package/host/planes/jobs.mjs +43 -20
- package/host/planes/latex.mjs +15 -5
- package/host/planes/mcp.mjs +80 -91
- package/host/planes/pair.mjs +24 -24
- package/host/planes/pipe-term.mjs +2 -2
- package/host/planes/plugins.mjs +1 -1
- package/host/planes/recent-documents.mjs +170 -0
- package/host/planes/sessions.mjs +226 -82
- package/host/planes/settings.mjs +4 -4
- package/host/planes/terminal.mjs +33 -17
- package/host/planes/test-file.mjs +2 -2
- package/host/planes/update.mjs +6 -13
- package/host/plugin-store.mjs +35 -52
- package/host/recent-documents.mjs +124 -0
- package/host/runtime-dir.mjs +47 -0
- package/host/server.mjs +75 -18
- package/host/session-keep.mjs +1 -1
- package/host/settings.mjs +85 -37
- package/host/update-record.mjs +3 -2
- package/host/user-dirs.mjs +60 -18
- package/host/which.mjs +39 -0
- package/host/windows-runtime.mjs +6 -3
- package/host/worker-plane.mjs +34 -6
- package/host/ws.mjs +9 -2
- package/host/zip.mjs +237 -0
- package/kernel/analyze.R +1 -1
- package/{check → kernel/check}/acceptance.mjs +1 -1
- package/kernel/check/knit-file.mjs +19855 -0
- package/{check → kernel/check}/session.mjs +49 -8
- package/kernel/deployment.R +20 -20
- package/kernel/examples/NOTICE.md +1 -1
- package/kernel/fileio.R +6 -6
- package/kernel/index.html +2 -2
- package/kernel/job-run.R +83 -22
- package/kernel/jobs.R +28 -12
- package/kernel/kernel-version +1 -1
- package/kernel/kernel.R +18 -18
- package/kernel/knitr-run.R +58 -10
- package/kernel/latex.R +128 -30
- package/kernel/mcp/{carmar-mcp.mjs → beatrina-mcp.mjs} +254 -63
- package/kernel/notebook-page.R +7 -7
- package/kernel/project.R +10 -10
- package/kernel/settings.R +105 -56
- package/kernel/sniff.R +4 -4
- package/kernel/typst.R +121 -0
- package/kernel/worker.R +542 -119
- package/kernel/workspace-keep.R +3 -3
- package/lib/agent-authoring-contract.js +28 -19
- package/lib/cell-kinds.js +3 -3
- package/lib/engine-labels.js +4 -4
- package/menu/Beatrina Menu.app/Contents/Info.plist +14 -0
- package/menu/Beatrina Menu.app/Contents/MacOS/Beatrina Menu +0 -0
- package/menu/Beatrina Menu.app/Contents/_CodeSignature/CodeResources +115 -0
- package/package.json +4 -3
- package/carmar_V0.8.7.html +0 -1522
package/kernel/worker.R
CHANGED
|
@@ -63,9 +63,9 @@ local({
|
|
|
63
63
|
# interactive worker MUST read through R's console (stdin()), because that is
|
|
64
64
|
# the one reader a native browser() prompt shares — a second buffered reader
|
|
65
65
|
# on the same fd would steal bytes from the debugger.
|
|
66
|
-
WORKER_MODE <- Sys.getenv("
|
|
66
|
+
WORKER_MODE <- Sys.getenv("BEATRINA_WORKER_MODE", "batch")
|
|
67
67
|
sentinel <- if (identical(WORKER_MODE, "interactive")) {
|
|
68
|
-
Sys.getenv("
|
|
68
|
+
Sys.getenv("BEATRINA_SENTINEL", "")
|
|
69
69
|
} else {
|
|
70
70
|
args <- commandArgs(trailingOnly = TRUE)
|
|
71
71
|
if (length(args) >= 1L) args[1] else ""
|
|
@@ -75,13 +75,89 @@ stopifnot(nzchar(sentinel))
|
|
|
75
75
|
# mode — a comment, so a line that ever reached R's raw top level would be
|
|
76
76
|
# inert. The prefix is stripped here before parsing.
|
|
77
77
|
CMD_PREFIX <- local({
|
|
78
|
-
tag <- Sys.getenv("
|
|
78
|
+
tag <- Sys.getenv("BEATRINA_CMD_TAG", "")
|
|
79
79
|
if (nzchar(tag)) paste0("#", tag, " ") else ""
|
|
80
80
|
})
|
|
81
81
|
|
|
82
82
|
PLOT_WIDTH <- 900L
|
|
83
83
|
PLOT_HEIGHT <- 620L
|
|
84
84
|
PLOT_RES <- 110L
|
|
85
|
+
|
|
86
|
+
#' knitr's OWN figure defaults, captured before any user code runs.
|
|
87
|
+
#'
|
|
88
|
+
#' The baseline that lets knitr_dim_defaults() tell "this document asked for a
|
|
89
|
+
#' 10-inch figure" from "knitr answered with its own 7-inch default". Read at
|
|
90
|
+
#' load time on purpose: after a setup chunk has run it is no longer pristine.
|
|
91
|
+
KNITR_FIG_BASE <- local({
|
|
92
|
+
if (!requireNamespace("knitr", quietly = TRUE)) return(NULL)
|
|
93
|
+
tryCatch(knitr::opts_chunk$get(c("fig.width", "fig.height", "dpi")),
|
|
94
|
+
error = function(e) NULL)
|
|
95
|
+
})
|
|
96
|
+
|
|
97
|
+
#' The document's own figure defaults, from knitr.
|
|
98
|
+
#'
|
|
99
|
+
#' `knitr::opts_chunk$set(fig.width = 10, dpi = 150)` in a setup chunk is how
|
|
100
|
+
#' every R author states what size their figures are, and until 2026-09-18 an
|
|
101
|
+
#' interactive run ignored it completely: the call looked like configuration
|
|
102
|
+
#' and did nothing, and the PNGs came back at this file's constants whatever
|
|
103
|
+
#' the document said. knitr sizes in INCHES and carries the resolution
|
|
104
|
+
#' separately, which is exactly a raster device's width = inches * dpi.
|
|
105
|
+
#'
|
|
106
|
+
#' Precedence, widest to narrowest: what the page sent for THIS run (the
|
|
107
|
+
#' chunk's own fig.width, or the editor's device settings) wins, because it is
|
|
108
|
+
#' more specific than a document default; then these; then the constants.
|
|
109
|
+
#'
|
|
110
|
+
#' @return A list with any of width/height/res in pixels, or an empty list.
|
|
111
|
+
knitr_dim_defaults <- function() {
|
|
112
|
+
if (!requireNamespace("knitr", quietly = TRUE)) return(list())
|
|
113
|
+
got <- tryCatch(knitr::opts_chunk$get(c("fig.width", "fig.height", "dpi")),
|
|
114
|
+
error = function(e) NULL)
|
|
115
|
+
if (!is.list(got)) return(list())
|
|
116
|
+
# Only what the DOCUMENT set. knitr always answers with something — its own
|
|
117
|
+
# defaults are 7in by 7in at 72 dpi — so honouring whatever it says would
|
|
118
|
+
# shrink every plot in every notebook that never mentioned figures, from 900
|
|
119
|
+
# pixels to 504. KNITR_FIG_BASE is knitr's pristine answer, captured at boot
|
|
120
|
+
# before a line of anyone's code has run; a value equal to it was not asked
|
|
121
|
+
# for by this document and is ignored.
|
|
122
|
+
base <- KNITR_FIG_BASE
|
|
123
|
+
if (is.list(base)) {
|
|
124
|
+
for (key in c("fig.width", "fig.height", "dpi")) {
|
|
125
|
+
if (!is.null(base[[key]]) && !is.null(got[[key]]) && isTRUE(all.equal(base[[key]], got[[key]]))) got[[key]] <- NULL
|
|
126
|
+
}
|
|
127
|
+
}
|
|
128
|
+
num <- function(x) if (is.numeric(x) && length(x) == 1L && is.finite(x) && x > 0) as.numeric(x) else NULL
|
|
129
|
+
dpi <- num(got$dpi)
|
|
130
|
+
w <- num(got$fig.width)
|
|
131
|
+
h <- num(got$fig.height)
|
|
132
|
+
out <- list()
|
|
133
|
+
if (!is.null(dpi)) out$res <- as.integer(round(dpi))
|
|
134
|
+
# Inches become pixels only when there is a resolution to multiply by; with
|
|
135
|
+
# no dpi set, knitr's own default of 72 is what a figure of that width means.
|
|
136
|
+
scale <- if (!is.null(dpi)) dpi else 72
|
|
137
|
+
if (!is.null(w)) out$width <- as.integer(round(w * scale))
|
|
138
|
+
if (!is.null(h)) out$height <- as.integer(round(h * scale))
|
|
139
|
+
out
|
|
140
|
+
}
|
|
141
|
+
|
|
142
|
+
#' The document's chosen display precision, or NULL if it never chose one.
|
|
143
|
+
#'
|
|
144
|
+
#' R's factory default is 7. A document that says `options(digits = 3)` means
|
|
145
|
+
#' its tables to read at three significant digits, and says it once, in a setup
|
|
146
|
+
#' chunk — so the value travels with every frame rather than being asked for
|
|
147
|
+
#' per table.
|
|
148
|
+
display_digits <- function() {
|
|
149
|
+
d <- getOption("digits", 7L)
|
|
150
|
+
if (!is.numeric(d) || length(d) != 1L || !is.finite(d) || d == 7L) return(NULL)
|
|
151
|
+
as.integer(max(1L, min(22L, round(d))))
|
|
152
|
+
}
|
|
153
|
+
|
|
154
|
+
#' One dimension, resolved: this run's value, else the document's, else ours.
|
|
155
|
+
dim_or <- function(value, key) {
|
|
156
|
+
if (!is.null(value)) return(value)
|
|
157
|
+
doc <- knitr_dim_defaults()
|
|
158
|
+
if (!is.null(doc[[key]])) return(doc[[key]])
|
|
159
|
+
switch(key, width = PLOT_WIDTH, height = PLOT_HEIGHT, res = PLOT_RES)
|
|
160
|
+
}
|
|
85
161
|
# Hard ceilings for the data viewer. Server-side because the client is one
|
|
86
162
|
# `limit: 1e9` typo away from asking for everything; the reply reports what was
|
|
87
163
|
# clamped, so the UI never has to guess what it actually received.
|
|
@@ -90,6 +166,13 @@ MAX_VIEW_COLS <- 100L
|
|
|
90
166
|
MAX_VIEW_BYTES <- 512L * 1024L
|
|
91
167
|
MAX_VIEW_CELL_CHARS <- 512L
|
|
92
168
|
MAX_VIEW_LABEL_CHARS <- 128L
|
|
169
|
+
# The viewer's page size, the same number as lib/panel.js's PAGE (pinned by
|
|
170
|
+
# spike/test-ide.R). View() pushes its first page unasked, and it
|
|
171
|
+
# used to take the `view` op's protocol default of 200, so the grid opened on
|
|
172
|
+
# "1–200 of N" and every page it asked for itself — next, search, clear — was
|
|
173
|
+
# 50 (N11, app-monkey soak 2026-09-22). The protocol default stays 200 for
|
|
174
|
+
# clients that name no limit; the push names the viewer's.
|
|
175
|
+
VIEWER_PAGE_ROWS <- 50L
|
|
93
176
|
MAX_STRUCT_CHILDREN <- 200L
|
|
94
177
|
MAX_COMPLETIONS <- 200L
|
|
95
178
|
|
|
@@ -114,13 +197,13 @@ try(utils::rc.settings(ipck = TRUE, func = TRUE, args = TRUE, files = TRUE),
|
|
|
114
197
|
# is started by three different launchers (kernel.R, the Chrome bridge host,
|
|
115
198
|
# and the packaged inst/app/kernel) and none of them guarantee a cwd.
|
|
116
199
|
import_sources <- local({
|
|
117
|
-
env_dir <- Sys.getenv("
|
|
200
|
+
env_dir <- Sys.getenv("BEATRINA_WORKER_DIR", "")
|
|
118
201
|
file_arg <- grep("^--file=", commandArgs(FALSE), value = TRUE)
|
|
119
202
|
here <- if (nzchar(env_dir)) env_dir
|
|
120
203
|
else if (length(file_arg)) {
|
|
121
204
|
dirname(normalizePath(sub("^--file=", "", file_arg[1L]), mustWork = FALSE))
|
|
122
205
|
} else getwd()
|
|
123
|
-
file.path(here, c("fileio.R", "sniff.R", "project.R", "workspace-keep.R"))
|
|
206
|
+
file.path(here, c("fileio.R", "sniff.R", "project.R", "workspace-keep.R", "deployment.R"))
|
|
124
207
|
})
|
|
125
208
|
# environment(), not parent.frame(): inside a nested local() the parent frame
|
|
126
209
|
# is the eval machinery's, not this file's private scope, and the functions
|
|
@@ -142,9 +225,9 @@ invisible(lapply(Filter(file.exists, import_sources),
|
|
|
142
225
|
# user already set: their .Rprofile loads here (we deliberately do not use
|
|
143
226
|
# --vanilla), and it is where r-universe and institutional mirrors live.
|
|
144
227
|
local({
|
|
145
|
-
managed_mirror <- trimws(Sys.getenv("
|
|
228
|
+
managed_mirror <- trimws(Sys.getenv("BEATRINA_CRAN_MIRROR", ""))
|
|
146
229
|
if (nzchar(managed_mirror) && !grepl("^https://", managed_mirror)) {
|
|
147
|
-
stop("
|
|
230
|
+
stop("BEATRINA_CRAN_MIRROR must be an HTTPS URL.")
|
|
148
231
|
}
|
|
149
232
|
repos <- getOption("repos")
|
|
150
233
|
cran <- if (is.null(repos)) NA_character_ else unname(repos["CRAN"])
|
|
@@ -191,7 +274,7 @@ R_KEYWORDS <- c("if", "else", "repeat", "while", "function", "for", "in",
|
|
|
191
274
|
#' CAIRO IS TRIED BEFORE QUARTZ, and that ORDER is a hang fix, not a
|
|
192
275
|
#' preference. `png(type="quartz")` pulls in the macOS Aqua/AppKit graphics
|
|
193
276
|
#' backend, which spawns a Cocoa event loop (an NSEventThread plus grDevices'
|
|
194
|
-
#' own ELThread) the first time it opens.
|
|
277
|
+
#' own ELThread) the first time it opens. Beatrina's worker is a BackgroundOnly
|
|
195
278
|
#' process with no window-server access, so when R pumps that event loop
|
|
196
279
|
#' mid-evaluation — which it does from inside a long R-level loop, e.g. the
|
|
197
280
|
#' permutation loop in `markov_order_test` — `ReceiveNextEventCommon` blocks
|
|
@@ -391,7 +474,10 @@ sys.source(file.path(here, "knitr-run.R"), envir = environment())
|
|
|
391
474
|
# code and every package keep seeing base's own function, and removing the
|
|
392
475
|
# attached frame restores the original behaviour exactly. The delegation is the
|
|
393
476
|
# whole implementation — announce, then let R do what it already did.
|
|
394
|
-
|
|
477
|
+
# The console reader itself, captured BEFORE the namespaces are patched below:
|
|
478
|
+
# the announcing wrapper must call the real one, never itself.
|
|
479
|
+
BASE_READLINE <- if (is.null(attr(base::readline, "beatrina"))) base::readline else attr(base::readline, "beatrina")
|
|
480
|
+
beatrina_readline <- function(prompt = "") {
|
|
395
481
|
text <- tryCatch(as.character(prompt)[[1]], error = function(e) "")
|
|
396
482
|
if (!length(text) || is.na(text)) text <- ""
|
|
397
483
|
# The question belongs to the RUN that asked it, and says so.
|
|
@@ -413,7 +499,7 @@ carmar_readline <- function(prompt = "") {
|
|
|
413
499
|
# id by finding the first `"id":…` in the worker's own bytes, so a prompt
|
|
414
500
|
# containing that text would otherwise be rewritten instead of the id.
|
|
415
501
|
emit(list(type = "input_request", id = RUN_STATE$id, prompt = text))
|
|
416
|
-
answer <-
|
|
502
|
+
answer <- BASE_READLINE(prompt)
|
|
417
503
|
# Symmetry matters more than it looks: a page that opened an input row on the
|
|
418
504
|
# request must be told to close it, INCLUDING when the answer arrived by some
|
|
419
505
|
# other route (an interrupt, a second page). Without this the prompt row
|
|
@@ -438,7 +524,7 @@ carmar_readline <- function(prompt = "") {
|
|
|
438
524
|
# RUN_STATE carries the current run's id from run_cell to the shadow.
|
|
439
525
|
RUN_STATE <- new.env(parent = emptyenv())
|
|
440
526
|
RUN_STATE$id <- NULL
|
|
441
|
-
|
|
527
|
+
beatrina_print <- function(x, ...) {
|
|
442
528
|
if (is.null(RUN_STATE$id) || length(list(...)) || sink.number() > (RUN_STATE$capture_depth %||% 0L)) {
|
|
443
529
|
return(base::print(x, ...))
|
|
444
530
|
}
|
|
@@ -457,8 +543,8 @@ carmar_print <- function(x, ...) {
|
|
|
457
543
|
}
|
|
458
544
|
base::print(x, ...)
|
|
459
545
|
}
|
|
460
|
-
INPUT_SHADOW <- "
|
|
461
|
-
|
|
546
|
+
INPUT_SHADOW <- "beatrina:input"
|
|
547
|
+
beatrina_flush_console <- function() {
|
|
462
548
|
if (!is.null(KNIT_CAPTURE)) evaluate::flush_console()
|
|
463
549
|
else utils::flush.console()
|
|
464
550
|
invisible(NULL)
|
|
@@ -467,10 +553,113 @@ if (!(INPUT_SHADOW %in% search())) {
|
|
|
467
553
|
# warn.conflicts = FALSE: masking `readline` (and `print`) is the entire
|
|
468
554
|
# point, and a startup warning about it would be printed into the user's
|
|
469
555
|
# first cell.
|
|
470
|
-
attach(list(readline =
|
|
556
|
+
attach(list(readline = beatrina_readline, print = beatrina_print, flush.console = beatrina_flush_console),
|
|
471
557
|
name = INPUT_SHADOW, warn.conflicts = FALSE)
|
|
472
558
|
}
|
|
473
559
|
|
|
560
|
+
# Console reads R's OWN helpers make are announced too (2026-09-19). The shadow
|
|
561
|
+
# above only answers for readline() typed in the user's code: askYesNo(),
|
|
562
|
+
# menu(), select.list(), scan("") and every package reach base and utils
|
|
563
|
+
# through their NAMESPACES, where a search-path shadow is invisible — measured:
|
|
564
|
+
# menu() printed its choices and the run sat blocked with no prompt on the
|
|
565
|
+
# page, and so did askYesNo, select.list and scan. So the readers are announced
|
|
566
|
+
# where everything funnels through them:
|
|
567
|
+
# - base::readline is the announcing reader in base's namespace and package
|
|
568
|
+
# env, so askYesNo() and every package's readline() ride it;
|
|
569
|
+
# - utils::menu's console loop is re-expressed over it (the original reads
|
|
570
|
+
# the console from C, C_menu, which nothing at R level can observe);
|
|
571
|
+
# - scan() from the console collects its lines through it and hands them to
|
|
572
|
+
# the real scan() as `text`.
|
|
573
|
+
# Each READ is announced, so a menu that re-asks after a bad answer opens a
|
|
574
|
+
# fresh prompt instead of having its answer refused by the one-line gate.
|
|
575
|
+
# The originals are kept (as the "beatrina" attribute, BASE_*), and the
|
|
576
|
+
# patching is idempotent.
|
|
577
|
+
|
|
578
|
+
#' Put `value` in place of `name` in a package's namespace and its attached env.
|
|
579
|
+
#' @return Invisibly, whether every present binding was replaced.
|
|
580
|
+
beatrina_patch <- function(name, value, pkg) {
|
|
581
|
+
envs <- Filter(Negate(is.null), list(asNamespace(pkg),
|
|
582
|
+
if (paste0("package:", pkg) %in% search()) as.environment(paste0("package:", pkg)) else NULL))
|
|
583
|
+
done <- vapply(envs, function(env) {
|
|
584
|
+
if (!exists(name, envir = env, inherits = FALSE)) return(TRUE)
|
|
585
|
+
locked <- bindingIsLocked(name, env)
|
|
586
|
+
if (locked) unlockBinding(name, env)
|
|
587
|
+
on.exit(if (locked) lockBinding(name, env), add = TRUE)
|
|
588
|
+
assign(name, value, envir = env)
|
|
589
|
+
TRUE
|
|
590
|
+
}, logical(1))
|
|
591
|
+
invisible(all(done))
|
|
592
|
+
}
|
|
593
|
+
|
|
594
|
+
#' menu() over the announced reader, faithful to utils::menu's console path:
|
|
595
|
+
#' the same layout, a number or an exact choice, 0 to exit, and the same
|
|
596
|
+
#' sentence on a bad answer. The graphics path is left to the original.
|
|
597
|
+
#' @return The chosen index, or 0.
|
|
598
|
+
BASE_MENU <- if (is.null(attr(utils::menu, "beatrina"))) utils::menu else attr(utils::menu, "beatrina")
|
|
599
|
+
beatrina_menu <- function(choices, graphics = FALSE, title = NULL) {
|
|
600
|
+
if (!interactive()) stop("menu() cannot be used non-interactively")
|
|
601
|
+
if (isTRUE(graphics)) return(BASE_MENU(choices, graphics = graphics, title = title))
|
|
602
|
+
choices <- as.character(choices)
|
|
603
|
+
nc <- length(choices)
|
|
604
|
+
if (length(title) && nzchar(title[1L])) cat(title[1L], "\n")
|
|
605
|
+
op <- paste0(format(seq_len(nc)), ": ", choices)
|
|
606
|
+
if (nc > 10L) {
|
|
607
|
+
fop <- format(op)
|
|
608
|
+
nw <- nchar(fop[1L], "w") + 2L
|
|
609
|
+
ncol <- getOption("width") %/% nw
|
|
610
|
+
if (ncol > 1L) op <- paste0(fop, c(rep.int(" ", min(nc, ncol) - 1L), "\n"), collapse = "")
|
|
611
|
+
}
|
|
612
|
+
cat("", op, "", sep = "\n")
|
|
613
|
+
# Recursion, not a loop: ask until the answer names an item (R's own menu
|
|
614
|
+
# repeats the same way; a person typing nonsense is the only way round).
|
|
615
|
+
ask <- function() {
|
|
616
|
+
ans <- trimws(beatrina_readline("Selection: "))
|
|
617
|
+
ind <- if (grepl("^[0-9]", ans)) suppressWarnings(as.integer(sub("^([0-9]+).*$", "\\1", ans)))
|
|
618
|
+
else match(ans, choices, nomatch = nc + 1L)
|
|
619
|
+
if (!is.na(ind) && ind <= nc) return(ind)
|
|
620
|
+
# gettext() trims the trailing newline off the message; it is said apart.
|
|
621
|
+
cat(gettext("Enter an item from the menu, or 0 to exit", domain = "R-utils"), "\n", sep = "")
|
|
622
|
+
ask()
|
|
623
|
+
}
|
|
624
|
+
ask()
|
|
625
|
+
}
|
|
626
|
+
attr(beatrina_menu, "beatrina") <- BASE_MENU
|
|
627
|
+
|
|
628
|
+
#' scan() from the console, through the announced reader. Lines are read the
|
|
629
|
+
#' way the console scan reads them — one prompt per line, numbered by the next
|
|
630
|
+
#' item, until a blank line, `nlines` lines, or `n`/`nmax` items — then the real
|
|
631
|
+
#' scan() parses them as `text`, so every argument keeps its meaning.
|
|
632
|
+
BASE_SCAN <- if (is.null(attr(base::scan, "beatrina"))) base::scan else attr(base::scan, "beatrina")
|
|
633
|
+
beatrina_scan <- BASE_SCAN
|
|
634
|
+
body(beatrina_scan) <- quote({
|
|
635
|
+
call <- match.call()
|
|
636
|
+
call[[1L]] <- BASE_SCAN
|
|
637
|
+
from_console <- is.character(file) && identical(file, "") && missing(text)
|
|
638
|
+
if (!from_console) return(eval(call, parent.frame()))
|
|
639
|
+
per_line <- function(line) {
|
|
640
|
+
parts <- if (nzchar(sep)) strsplit(line, sep, fixed = TRUE)[[1L]] else strsplit(trimws(line), "[ \t]+")[[1L]]
|
|
641
|
+
length(parts[nzchar(parts)])
|
|
642
|
+
}
|
|
643
|
+
want <- max(c(n, nmax, 0L)[c(n, nmax, 0L) > 0L][1L], 0L, na.rm = TRUE)
|
|
644
|
+
collect <- function(lines, items) {
|
|
645
|
+
if (nlines > 0L && length(lines) >= nlines) return(lines)
|
|
646
|
+
if (want > 0L && items >= want) return(lines)
|
|
647
|
+
line <- beatrina_readline(sprintf("%d: ", items + 1L))
|
|
648
|
+
if (!nzchar(trimws(line))) return(lines)
|
|
649
|
+
collect(c(lines, line), items + per_line(line))
|
|
650
|
+
}
|
|
651
|
+
call$file <- NULL
|
|
652
|
+
call$text <- paste(collect(character(), 0L), collapse = "\n")
|
|
653
|
+
eval(call, parent.frame())
|
|
654
|
+
})
|
|
655
|
+
attr(beatrina_scan, "beatrina") <- BASE_SCAN
|
|
656
|
+
attr(beatrina_readline, "beatrina") <- BASE_READLINE
|
|
657
|
+
environment(beatrina_scan) <- environment()
|
|
658
|
+
|
|
659
|
+
beatrina_patch("readline", beatrina_readline, "base")
|
|
660
|
+
beatrina_patch("scan", beatrina_scan, "base")
|
|
661
|
+
beatrina_patch("menu", beatrina_menu, "utils")
|
|
662
|
+
|
|
474
663
|
#' Never ask "Hit <Return> to see next plot".
|
|
475
664
|
#'
|
|
476
665
|
#' This worker is interactive, so a plot that turns page prompting on —
|
|
@@ -484,14 +673,14 @@ if (!(INPUT_SHADOW %in% search())) {
|
|
|
484
673
|
#' and simply never gets to ask.
|
|
485
674
|
#'
|
|
486
675
|
#' @return Invisibly NULL.
|
|
487
|
-
|
|
676
|
+
beatrina_no_page_prompt <- function() {
|
|
488
677
|
if (isTRUE(grDevices::devAskNewPage())) grDevices::devAskNewPage(FALSE)
|
|
489
678
|
invisible(NULL)
|
|
490
679
|
}
|
|
491
680
|
local({
|
|
492
|
-
already <- function(hook) any(vapply(getHook(hook), identical, logical(1),
|
|
493
|
-
if (!already("before.plot.new")) setHook("before.plot.new",
|
|
494
|
-
if (!already("before.grid.newpage")) setHook("before.grid.newpage",
|
|
681
|
+
already <- function(hook) any(vapply(getHook(hook), identical, logical(1), beatrina_no_page_prompt))
|
|
682
|
+
if (!already("before.plot.new")) setHook("before.plot.new", beatrina_no_page_prompt)
|
|
683
|
+
if (!already("before.grid.newpage")) setHook("before.grid.newpage", beatrina_no_page_prompt)
|
|
495
684
|
})
|
|
496
685
|
|
|
497
686
|
#' A function's formals as one display string, defaults included.
|
|
@@ -674,9 +863,9 @@ emit_struct <- function(id, name = NULL, path = NULL) {
|
|
|
674
863
|
child_get(o, k)
|
|
675
864
|
}
|
|
676
865
|
node <- tryCatch(Reduce(step, keys, init = get(name, envir = globalenv())),
|
|
677
|
-
error = function(e) structure(class = "
|
|
866
|
+
error = function(e) structure(class = "beatrina_fail",
|
|
678
867
|
list(msg = conditionMessage(e))))
|
|
679
|
-
if (inherits(node, "
|
|
868
|
+
if (inherits(node, "beatrina_fail")) {
|
|
680
869
|
emit(list(type = "struct", id = id, name = name, path = as.list(keys),
|
|
681
870
|
error = node$msg))
|
|
682
871
|
return(invisible(NULL))
|
|
@@ -978,6 +1167,88 @@ emit_colstats <- function(id, name, column, query = NULL, filters = NULL) {
|
|
|
978
1167
|
)
|
|
979
1168
|
}
|
|
980
1169
|
|
|
1170
|
+
#' The grid's copy door, R's half: one column, every row, as text.
|
|
1171
|
+
#'
|
|
1172
|
+
#' `Copy Column (all rows, through R)` (lib/panel.js `columnValues`,
|
|
1173
|
+
#' lib/command-system.js): the page holds one window of rows, so a whole
|
|
1174
|
+
#' column has to come from here. Same object resolution, same query and
|
|
1175
|
+
#' filters as `view` and `colstats`, so what is copied is the column of the
|
|
1176
|
+
#' rows the grid is showing — every one of them, not one page. Written the way
|
|
1177
|
+
#' `write.csv` writes it (header quoted, text quoted, numbers at full
|
|
1178
|
+
#' precision, NA bare, no row names) to a temporary file and read back: no
|
|
1179
|
+
#' sink, nothing evaluated but the name. Read-only.
|
|
1180
|
+
#'
|
|
1181
|
+
#' Bounded at COLUMN_VALUES_MAX values and refused above it with a sentence:
|
|
1182
|
+
#' a twenty-million-line clipboard is not a copy, it is an export, and the
|
|
1183
|
+
#' Export door sits one row down in the same menu.
|
|
1184
|
+
#'
|
|
1185
|
+
#' @param id Request id.
|
|
1186
|
+
#' @param name Object name or expression, as for `view`.
|
|
1187
|
+
#' @param column The column to copy.
|
|
1188
|
+
#' @param query,filters The viewer's active search and column filters.
|
|
1189
|
+
COLUMN_VALUES_MAX <- 1000000L
|
|
1190
|
+
|
|
1191
|
+
emit_column_values <- function(id, name, column, query = NULL, filters = NULL) {
|
|
1192
|
+
column <- if (is.character(column) && length(column)) column[[1L]] else ""
|
|
1193
|
+
reply <- function(...) emit(list(type = "column_values", id = id, name = name,
|
|
1194
|
+
column = column, ...))
|
|
1195
|
+
if (!is.character(name) || length(name) != 1L || is.na(name) || !nzchar(name)) {
|
|
1196
|
+
reply(error = "bad name")
|
|
1197
|
+
return(invisible(NULL))
|
|
1198
|
+
}
|
|
1199
|
+
obj <- tryCatch(eval(parse(text = name), globalenv()), error = function(e) NULL)
|
|
1200
|
+
# NULL is checked BEFORE coercion: as.data.frame(NULL) is an empty frame,
|
|
1201
|
+
# not NULL, and a missing object would otherwise read as "no such column".
|
|
1202
|
+
if (is.null(obj)) {
|
|
1203
|
+
reply(error = "not found")
|
|
1204
|
+
return(invisible(NULL))
|
|
1205
|
+
}
|
|
1206
|
+
if (!is.data.frame(obj)) obj <- tryCatch(as.data.frame(obj, stringsAsFactors = FALSE),
|
|
1207
|
+
error = function(e) NULL)
|
|
1208
|
+
if (is.null(obj) || !nzchar(column)) {
|
|
1209
|
+
reply(error = "not found")
|
|
1210
|
+
return(invisible(NULL))
|
|
1211
|
+
}
|
|
1212
|
+
total <- nrow(obj)
|
|
1213
|
+
narrowed <- view_filter(obj, query, filters)
|
|
1214
|
+
obj <- narrowed$obj
|
|
1215
|
+
hit <- match(column, names(obj))
|
|
1216
|
+
if (is.na(hit)) hit <- match(column, substr(names(obj), 1L, MAX_VIEW_LABEL_CHARS))
|
|
1217
|
+
if (is.na(hit)) {
|
|
1218
|
+
reply(error = "no such column")
|
|
1219
|
+
return(invisible(NULL))
|
|
1220
|
+
}
|
|
1221
|
+
n <- nrow(obj)
|
|
1222
|
+
if (n > COLUMN_VALUES_MAX) {
|
|
1223
|
+
reply(error = sprintf("%s has %s values; copying through R stops at %s. Export the table instead.",
|
|
1224
|
+
column, format(n, big.mark = ","),
|
|
1225
|
+
format(COLUMN_VALUES_MAX, big.mark = ",")),
|
|
1226
|
+
rows = n, totalRows = total)
|
|
1227
|
+
return(invisible(NULL))
|
|
1228
|
+
}
|
|
1229
|
+
# A temporary file, not a textConnection: the connection grows its vector a
|
|
1230
|
+
# line at a time and took 16 s for 100,000 rows where the file takes 50 ms
|
|
1231
|
+
# (measured 2026-09-17, identical text). UTF-8 both ways, so Windows' native
|
|
1232
|
+
# code page never enters the text. as.data.frame() first: a tibble or
|
|
1233
|
+
# data.table has its own `[`, and this must be base's one-column frame.
|
|
1234
|
+
tf <- tempfile("column-values-", fileext = ".csv")
|
|
1235
|
+
on.exit(unlink(tf), add = TRUE)
|
|
1236
|
+
written <- tryCatch({
|
|
1237
|
+
utils::write.csv(as.data.frame(obj)[hit], tf, row.names = FALSE, fileEncoding = "UTF-8")
|
|
1238
|
+
TRUE
|
|
1239
|
+
}, interrupt = function(i) FALSE, error = function(e) e)
|
|
1240
|
+
if (isTRUE(written)) {
|
|
1241
|
+
reply(text = paste(readLines(tf, encoding = "UTF-8", warn = FALSE), collapse = "\n"),
|
|
1242
|
+
rows = n, totalRows = total,
|
|
1243
|
+
filtered = nzchar(narrowed$query) || narrowed$count > 0L)
|
|
1244
|
+
} else if (isFALSE(written)) {
|
|
1245
|
+
reply(error = "interrupted")
|
|
1246
|
+
} else {
|
|
1247
|
+
reply(error = conditionMessage(written))
|
|
1248
|
+
}
|
|
1249
|
+
invisible(NULL)
|
|
1250
|
+
}
|
|
1251
|
+
|
|
981
1252
|
#' Autocomplete via R's own engine — the one behind TAB in the console,
|
|
982
1253
|
#' RStudio and Jupyter. Not hand-rolled: the engine already understands `$`
|
|
983
1254
|
#' and `@` access, argument names inside a call, `::` namespaces, library()
|
|
@@ -1074,15 +1345,125 @@ emit_complete <- function(id, line = NULL, cursor = NULL, max_items = MAX_COMPLE
|
|
|
1074
1345
|
}
|
|
1075
1346
|
list(value = v, kind = "variable", detail = detail)
|
|
1076
1347
|
}
|
|
1348
|
+
comps <- c(st$comps, case_blind_extras(st$token, st$comps, line, st$start, quoted))
|
|
1349
|
+
# R answers a `df$xyz` that matches nothing with the bare stub `df$`. As a
|
|
1350
|
+
# completion that is worse than none: accepting it REPLACES the token, so it
|
|
1351
|
+
# deletes the `xyz` the user typed and leaves incomplete syntax behind. It is
|
|
1352
|
+
# dropped only when the token already carries the separator — offering `x$`
|
|
1353
|
+
# for a token of `x`, or `stats::` for `stat`, is the useful "there is more
|
|
1354
|
+
# inside this" hint RStudio gives, and those stay. `pkg::` behaves the same
|
|
1355
|
+
# way as `$` and `@` here, so all three are one rule.
|
|
1356
|
+
SEP_END <- "([$@]|:::?)$"
|
|
1357
|
+
if (grepl("([$@]|::)", st$token) && !grepl(SEP_END, st$token)) {
|
|
1358
|
+
comps <- comps[!grepl(SEP_END, comps)]
|
|
1359
|
+
}
|
|
1077
1360
|
frame <- list(type = "complete", id = id, start = st$start, end = cursor,
|
|
1078
1361
|
token = st$token,
|
|
1079
|
-
items = lapply(utils::head(
|
|
1080
|
-
truncated = length(
|
|
1362
|
+
items = lapply(utils::head(comps, max_items), describe_item),
|
|
1363
|
+
truncated = length(comps) > max_items)
|
|
1081
1364
|
frame$args <- I(completion_call_args(fn))
|
|
1082
1365
|
frame$columns <- completion_columns(data, max_items)
|
|
1083
1366
|
emit(frame)
|
|
1084
1367
|
}
|
|
1085
1368
|
|
|
1369
|
+
#' Names that match the typed token when case is ignored.
|
|
1370
|
+
#'
|
|
1371
|
+
#' R's own completion engine (`utils:::.completeToken`) matches case-SENSITIVELY
|
|
1372
|
+
#' and has no option not to: typing `rda` offers nothing at all for an object
|
|
1373
|
+
#' called `Rdata`, and `myv` offers nothing for `myVar`. The page's own
|
|
1374
|
+
#' candidates — the names it parses out of the notebook's source — have always
|
|
1375
|
+
#' matched case-blind (`lib/completion-merge.js`), so the same keystroke
|
|
1376
|
+
#' completed a name written in a chunk and did NOT complete the same name once
|
|
1377
|
+
#' it existed in the session. One editor, two rules, decided by where the name
|
|
1378
|
+
#' happened to live.
|
|
1379
|
+
#'
|
|
1380
|
+
#' Case is ignored for EVERY token, `myV` as much as `rda`. A first shape of
|
|
1381
|
+
#' this left mixed-case tokens to R's exact matching on the theory that a
|
|
1382
|
+
#' capital typed mid-word was deliberate — but the page's parsed candidates
|
|
1383
|
+
#' never made that distinction, so it would have rebuilt the same split this
|
|
1384
|
+
#' function exists to close, one spelling further along. Completion is case
|
|
1385
|
+
#' insensitive; there is no second rule.
|
|
1386
|
+
#'
|
|
1387
|
+
#' These are EXTRAS, appended: an exact-case match is still found the way it
|
|
1388
|
+
#' always was, and `lib/completion-merge.js` already sorts a prefix match that
|
|
1389
|
+
#' differs in case below one that does not, so nothing moves in a list that was
|
|
1390
|
+
#' already right.
|
|
1391
|
+
#'
|
|
1392
|
+
#' Refused where a dotted or quoted context means the names are not the search
|
|
1393
|
+
#' path's: `df$`, `obj@`, `pkg::` and a path inside a string are R's to answer,
|
|
1394
|
+
#' and sweeping globals into them would offer names that cannot be used there.
|
|
1395
|
+
#'
|
|
1396
|
+
#' Measured at 2.4 ms over a 2,482-name search path — one sweep per keystroke
|
|
1397
|
+
#' that reaches the kernel, against a round trip that costs more than that.
|
|
1398
|
+
#'
|
|
1399
|
+
#' Every context R answers is covered, because "autocomplete is case
|
|
1400
|
+
#' insensitive" with an exception is two rules again: a bare name against the
|
|
1401
|
+
#' search path, `df$col`, `obj@slot`, and `pkg::name`. Each gets its OWN
|
|
1402
|
+
#' candidate set — the object's names, the object's slots, the namespace's
|
|
1403
|
+
#' exports — so nothing is offered where it could not be used.
|
|
1404
|
+
#'
|
|
1405
|
+
#' NOTHING IS EVALUATED to answer a keystroke. The head of a `$`/`@`/`::` is
|
|
1406
|
+
#' accepted only as a plain name and looked up with `get0`, and a namespace is
|
|
1407
|
+
#' read only when it is ALREADY loaded — the same rule
|
|
1408
|
+
#' `completion_call_args()` follows, for the same reason.
|
|
1409
|
+
#'
|
|
1410
|
+
#' @param token The token R guessed, as typed. R reports the WHOLE token for a
|
|
1411
|
+
#' dotted context (`x$al`, not `al`), which is what makes splitting it here
|
|
1412
|
+
#' the right place rather than re-deriving the head from the line.
|
|
1413
|
+
#' @param comps What R already matched, so nothing is offered twice.
|
|
1414
|
+
#' @param line The whole line, for the character before the token.
|
|
1415
|
+
#' @param start R's own start offset for the token (1-based, before the token).
|
|
1416
|
+
#' @param quoted Whether the token sits inside a string.
|
|
1417
|
+
#' @return Character vector of extra completions, spelled as R spells them
|
|
1418
|
+
#' (prefix included for a dotted context); empty when the context is one this
|
|
1419
|
+
#' cannot answer.
|
|
1420
|
+
case_blind_extras <- function(token, comps, line, start, quoted) {
|
|
1421
|
+
if (isTRUE(quoted)) return(character(0))
|
|
1422
|
+
if (!is.character(token) || length(token) != 1L || is.na(token)) return(character(0))
|
|
1423
|
+
# A prefix is safe to splice back only because `is_completion_name` vets the
|
|
1424
|
+
# head; the one regex metacharacter either half can carry is then the dot.
|
|
1425
|
+
starts_with <- function(pool, tail) {
|
|
1426
|
+
if (!length(pool)) return(character(0))
|
|
1427
|
+
pattern <- paste0("^", gsub(".", "\\.", tail, fixed = TRUE))
|
|
1428
|
+
pool[grepl(pattern, pool, ignore.case = TRUE)]
|
|
1429
|
+
}
|
|
1430
|
+
# `x$al` / `obj@sl` / `pkg::na` — R hands the whole thing over as one token.
|
|
1431
|
+
dotted <- regmatches(token, regexec("^(.*?)(\\$|@|:::?)([^$@:]*)$", token))[[1L]]
|
|
1432
|
+
if (length(dotted) == 4L) {
|
|
1433
|
+
head <- dotted[[2L]]; sep <- dotted[[3L]]; tail <- dotted[[4L]]
|
|
1434
|
+
if (!is_completion_name(head)) return(character(0))
|
|
1435
|
+
pool <- if (sep %in% c("::", ":::")) {
|
|
1436
|
+
if (head %in% loadedNamespaces())
|
|
1437
|
+
tryCatch(ls(asNamespace(head)), error = function(...) character(0))
|
|
1438
|
+
else character(0)
|
|
1439
|
+
} else {
|
|
1440
|
+
obj <- tryCatch(get0(head, envir = globalenv()), error = function(...) NULL)
|
|
1441
|
+
if (is.null(obj)) character(0)
|
|
1442
|
+
else if (identical(sep, "@")) tryCatch(methods::slotNames(obj), error = function(...) character(0))
|
|
1443
|
+
else if (is.environment(obj)) tryCatch(ls(obj), error = function(...) character(0))
|
|
1444
|
+
else tryCatch(names(obj), error = function(...) character(0))
|
|
1445
|
+
}
|
|
1446
|
+
matched <- starts_with(pool, tail)
|
|
1447
|
+
# `paste0("x", "$", character(0))` is "x$", not nothing — paste recycles a
|
|
1448
|
+
# zero-length argument as "". Without this the empty answer for an object
|
|
1449
|
+
# that does not exist came back as a completion to the bare prefix.
|
|
1450
|
+
if (!length(matched)) return(character(0))
|
|
1451
|
+
hits <- paste0(head, sep, matched)
|
|
1452
|
+
return(setdiff(hits, c(comps, sub("\\($", "", comps))))
|
|
1453
|
+
}
|
|
1454
|
+
if (!is_completion_name(token)) return(character(0))
|
|
1455
|
+
# A bare tail sitting right after a separator is a shape this cannot place —
|
|
1456
|
+
# the head is not in the token, so refuse rather than sweep in globals that
|
|
1457
|
+
# could not be used there.
|
|
1458
|
+
before <- if (start > 1L) substr(line, start - 1L, start - 1L) else ""
|
|
1459
|
+
if (before %in% c("$", "@", ":")) return(character(0))
|
|
1460
|
+
names <- unique(unlist(lapply(search(), function(e)
|
|
1461
|
+
tryCatch(ls(e), error = function(...) character(0)))))
|
|
1462
|
+
# Drop what R already offered, in either of the two spellings it ships
|
|
1463
|
+
# (`name` and `name(` for a function).
|
|
1464
|
+
setdiff(starts_with(names, token), c(comps, sub("\\($", "", comps)))
|
|
1465
|
+
}
|
|
1466
|
+
|
|
1086
1467
|
#' A bare R name, or `pkg::name` — the only shape a completion context may
|
|
1087
1468
|
#' name. Anything else (a call, a subset, an expression) is refused, because
|
|
1088
1469
|
#' these names are looked up, and a lookup must never become an evaluation.
|
|
@@ -1471,14 +1852,14 @@ emit_sniff <- function(id, path = NULL, opts = NULL) {
|
|
|
1471
1852
|
if (!file.exists(p) || dir.exists(p)) return(fail("not a readable file"))
|
|
1472
1853
|
}
|
|
1473
1854
|
if (!exists("sniff_file", inherits = TRUE)) {
|
|
1474
|
-
return(fail("this kernel is too old for the import wizard - restart
|
|
1855
|
+
return(fail("this kernel is too old for the import wizard - restart Beatrina"))
|
|
1475
1856
|
}
|
|
1476
1857
|
res <- tryCatch(
|
|
1477
1858
|
sniff_file(p, if (is.list(opts)) opts else list()),
|
|
1478
|
-
error = function(e) structure(class = "
|
|
1479
|
-
interrupt = function(i) structure(class = "
|
|
1859
|
+
error = function(e) structure(class = "beatrina_fail", list(msg = conditionMessage(e))),
|
|
1860
|
+
interrupt = function(i) structure(class = "beatrina_fail", list(msg = "interrupted"))
|
|
1480
1861
|
)
|
|
1481
|
-
if (inherits(res, "
|
|
1862
|
+
if (inherits(res, "beatrina_fail")) return(fail(res$msg))
|
|
1482
1863
|
emit(c(list(type = "sniff", id = id), res))
|
|
1483
1864
|
}
|
|
1484
1865
|
|
|
@@ -1517,10 +1898,10 @@ emit_import <- function(id, path = NULL, name = NULL) {
|
|
|
1517
1898
|
}
|
|
1518
1899
|
obj <- tryCatch(
|
|
1519
1900
|
if (requireNamespace("rio", quietly = TRUE)) rio::import(p) else read_by_ext(p),
|
|
1520
|
-
error = function(e) structure(class = "
|
|
1521
|
-
interrupt = function(i) structure(class = "
|
|
1901
|
+
error = function(e) structure(class = "beatrina_fail", list(msg = conditionMessage(e))),
|
|
1902
|
+
interrupt = function(i) structure(class = "beatrina_fail", list(msg = "interrupted"))
|
|
1522
1903
|
)
|
|
1523
|
-
if (inherits(obj, "
|
|
1904
|
+
if (inherits(obj, "beatrina_fail")) return(fail(obj$msg))
|
|
1524
1905
|
nm <- if (is.character(name) && length(name) == 1L && nzchar(name)) name
|
|
1525
1906
|
else make.names(tools::file_path_sans_ext(basename(p)))
|
|
1526
1907
|
assign(nm, obj, envir = globalenv())
|
|
@@ -1783,14 +2164,14 @@ emit_package_action <- function(id, action, name, lib = NULL) {
|
|
|
1783
2164
|
|
|
1784
2165
|
#' Project and renv state, without paths or lockfile contents on the wire.
|
|
1785
2166
|
emit_project_status <- function(id) {
|
|
1786
|
-
result <- tryCatch(
|
|
2167
|
+
result <- tryCatch(beatrina_project_status(), error = function(e)
|
|
1787
2168
|
list(error = conditionMessage(e)))
|
|
1788
2169
|
emit(c(list(type = "project_status", id = id), result))
|
|
1789
2170
|
}
|
|
1790
2171
|
|
|
1791
2172
|
#' One explicit, visible environment action: install renv or restore its lock.
|
|
1792
2173
|
emit_project_action <- function(id, action) {
|
|
1793
|
-
result <- tryCatch(
|
|
2174
|
+
result <- tryCatch(beatrina_project_action(action), error = function(e)
|
|
1794
2175
|
list(ok = FALSE, error = conditionMessage(e)))
|
|
1795
2176
|
emit(c(list(type = "project_action", id = id, action = action), result))
|
|
1796
2177
|
}
|
|
@@ -1851,7 +2232,7 @@ emit_help <- function(id, topic) {
|
|
|
1851
2232
|
} else {
|
|
1852
2233
|
txt <- paste(utils::capture.output(base::print(paths)), collapse = "\n")
|
|
1853
2234
|
if (!nzchar(trimws(txt))) NULL
|
|
1854
|
-
else paste0("<pre class=\"
|
|
2235
|
+
else paste0("<pre class=\"beatrina-help-text\">",
|
|
1855
2236
|
gsub("<", "<", gsub("&", "&", txt), fixed = TRUE), "</pre>")
|
|
1856
2237
|
}
|
|
1857
2238
|
}, error = function(e) NULL)
|
|
@@ -2001,7 +2382,7 @@ emit_wd <- function(id, path = NULL) {
|
|
|
2001
2382
|
|
|
2002
2383
|
# The file system lives in fileio.R (shared with the supervisor). Each op is
|
|
2003
2384
|
# `emit(fs_x(...))`: fileio.R returns the frame, this process sends it. The
|
|
2004
|
-
# worker still answers them when the supervisor forwards (
|
|
2385
|
+
# worker still answers them when the supervisor forwards (BEATRINA_FILE_OPS=worker,
|
|
2005
2386
|
# the transition flag), so nothing here may diverge from fileio.R.
|
|
2006
2387
|
emit_files <- function(id, path = NULL, all = FALSE) emit(fs_files(id, path, all, wd = getwd()))
|
|
2007
2388
|
emit_mkdir <- function(id, path = NULL) emit(fs_mkdir(id, path, wd = getwd()))
|
|
@@ -2014,7 +2395,7 @@ emit_writefile <- function(id, path = NULL, text = "", expected = NULL, encoding
|
|
|
2014
2395
|
emit(fs_writefile(id, path, text, expected, encoding, base64, wd = getwd()))
|
|
2015
2396
|
emit_writefiles_atomic <- function(id, files = NULL) emit(fs_writefiles_atomic(id, files, wd = getwd()))
|
|
2016
2397
|
|
|
2017
|
-
#' Check whether
|
|
2398
|
+
#' Check whether Beatrina's current R session is usable without collecting user
|
|
2018
2399
|
#' material.
|
|
2019
2400
|
#'
|
|
2020
2401
|
#' This reply is deliberately a FACT ALLOW-LIST. It never contains getwd(),
|
|
@@ -2028,12 +2409,12 @@ emit_writefiles_atomic <- function(id, files = NULL) emit(fs_writefiles_atomic(i
|
|
|
2028
2409
|
emit_doctor <- function(id) {
|
|
2029
2410
|
can_create_in <- function(dir) {
|
|
2030
2411
|
if (!is.character(dir) || length(dir) != 1L || !dir.exists(dir)) return(FALSE)
|
|
2031
|
-
probe <- tempfile(".
|
|
2412
|
+
probe <- tempfile(".beatrina-doctor-", tmpdir = dir)
|
|
2032
2413
|
on.exit(unlink(probe, force = TRUE), add = TRUE)
|
|
2033
2414
|
isTRUE(tryCatch(file.create(probe, showWarnings = FALSE), error = function(e) FALSE))
|
|
2034
2415
|
}
|
|
2035
2416
|
|
|
2036
|
-
q_configured <- trimws(Sys.getenv("
|
|
2417
|
+
q_configured <- trimws(Sys.getenv("BEATRINA_QUARTO", ""))
|
|
2037
2418
|
q_path <- if (nzchar(q_configured)) q_configured else unname(Sys.which("quarto"))
|
|
2038
2419
|
q_available <- is.character(q_path) && length(q_path) == 1L && nzchar(q_path) && file.exists(q_path)
|
|
2039
2420
|
q_version <- ""
|
|
@@ -2079,16 +2460,26 @@ emit_doctor <- function(id) {
|
|
|
2079
2460
|
version = q_version
|
|
2080
2461
|
),
|
|
2081
2462
|
required_packages = required,
|
|
2082
|
-
|
|
2083
|
-
|
|
2084
|
-
|
|
2085
|
-
|
|
2086
|
-
|
|
2087
|
-
|
|
2088
|
-
|
|
2089
|
-
|
|
2090
|
-
|
|
2091
|
-
|
|
2463
|
+
# ASKED, not re-derived. Doctor's own copy of the posture rule had drifted:
|
|
2464
|
+
# `!identical(Sys.getenv("BEATRINA_REQUIRE_ORIGIN", "1"), "0")` is TRUE
|
|
2465
|
+
# whenever the variable is unset, while the real rule (deployment.R, and
|
|
2466
|
+
# host/deployment.mjs, which agree) is `== "1" || !loopback` — FALSE on a
|
|
2467
|
+
# default desktop session. So Doctor reported an origin check the host was
|
|
2468
|
+
# not enforcing, and lib/doctor.js computes its managed-remote verdict from
|
|
2469
|
+
# exactly these fields. The loopback list had drifted too, missing "[::1]".
|
|
2470
|
+
deployment = local({
|
|
2471
|
+
d <- beatrina_deployment(as.integer(Sys.getenv("BEATRINA_PORT", "0")))
|
|
2472
|
+
list(
|
|
2473
|
+
loopback = isTRUE(d$loopback),
|
|
2474
|
+
confinement = nzchar(Sys.getenv("BEATRINA_ROOT", "")),
|
|
2475
|
+
audit = nzchar(Sys.getenv("BEATRINA_LOG", "")),
|
|
2476
|
+
ai_local_only = identical(Sys.getenv("BEATRINA_AI_LOCAL_ONLY", ""), "1"),
|
|
2477
|
+
ai_policy = nzchar(Sys.getenv("BEATRINA_AI_POLICY", "")) || nzchar(Sys.getenv("BEATRINA_AI_PROVIDERS", "")),
|
|
2478
|
+
origin_required = isTRUE(d$require_origin),
|
|
2479
|
+
trusted_proxy = isTRUE(d$trust_proxy),
|
|
2480
|
+
unauthenticated = isTRUE(d$allow_unauthenticated)
|
|
2481
|
+
)
|
|
2482
|
+
}),
|
|
2092
2483
|
proxy = list(
|
|
2093
2484
|
http = nzchar(Sys.getenv("HTTP_PROXY", "")) || nzchar(Sys.getenv("http_proxy", "")),
|
|
2094
2485
|
https = nzchar(Sys.getenv("HTTPS_PROXY", "")) || nzchar(Sys.getenv("https_proxy", "")),
|
|
@@ -2107,9 +2498,9 @@ emit_doctor <- function(id) {
|
|
|
2107
2498
|
#' @param seq Index of the top-level expression, to keep filenames unique.
|
|
2108
2499
|
#' @return Invisibly NULL.
|
|
2109
2500
|
open_plot_device <- function(dir, seq, dims = NULL) {
|
|
2110
|
-
width <-
|
|
2111
|
-
height <-
|
|
2112
|
-
res <-
|
|
2501
|
+
width <- dim_or(dims$width, "width")
|
|
2502
|
+
height <- dim_or(dims$height, "height")
|
|
2503
|
+
res <- dim_or(dims$res, "res")
|
|
2113
2504
|
if (plot_is_svg(dims)) {
|
|
2114
2505
|
# A vector device is sized in INCHES and has no resolution at all — which
|
|
2115
2506
|
# is the whole point: its cost does not grow with dpi. The client sends
|
|
@@ -2162,9 +2553,9 @@ emit_plot_frame <- function(id, f, dims = NULL) {
|
|
|
2162
2553
|
# older client would have rendered nothing at all.
|
|
2163
2554
|
svg <- grepl("\\.svg$", f)
|
|
2164
2555
|
emit(list(type = "plot", id = id, mime = if (svg) "image/svg+xml" else "image/png",
|
|
2165
|
-
width =
|
|
2166
|
-
height =
|
|
2167
|
-
res =
|
|
2556
|
+
width = dim_or(dims$width, "width"),
|
|
2557
|
+
height = dim_or(dims$height, "height"),
|
|
2558
|
+
res = dim_or(dims$res, "res"),
|
|
2168
2559
|
data = jsonlite::base64_enc(readBin(f, "raw", file.info(f)$size))))
|
|
2169
2560
|
invisible(NULL)
|
|
2170
2561
|
}
|
|
@@ -2195,9 +2586,9 @@ emit_plot_frame <- function(id, f, dims = NULL) {
|
|
|
2195
2586
|
.blank_png_cache <- new.env(parent = emptyenv())
|
|
2196
2587
|
is_blank_plot <- function(f, dims) {
|
|
2197
2588
|
if (!identical(RASTER_DEVICE, "ragg")) return(FALSE)
|
|
2198
|
-
w <-
|
|
2199
|
-
h <-
|
|
2200
|
-
r <-
|
|
2589
|
+
w <- dim_or(dims$width, "width")
|
|
2590
|
+
h <- dim_or(dims$height, "height")
|
|
2591
|
+
r <- dim_or(dims$res, "res")
|
|
2201
2592
|
key <- paste(w, h, r, sep = "x")
|
|
2202
2593
|
blank <- .blank_png_cache[[key]]
|
|
2203
2594
|
if (is.null(blank)) {
|
|
@@ -2296,6 +2687,14 @@ emit_dataframe <- function(id, df, source = NULL) {
|
|
|
2296
2687
|
# R whether names are automatic without materialising them; explicit names
|
|
2297
2688
|
# are sliced from the raw attribute only AFTER the 10-row preview is taken.
|
|
2298
2689
|
explicit_rownames <- .row_names_info(df, type = 1L) > 0L
|
|
2690
|
+
# head(df) and df[1:n, ] store their row names EXPLICITLY as the integers
|
|
2691
|
+
# 1..n — automatic in all but storage. Shown, they were a "rowname" column of
|
|
2692
|
+
# 1, 2, 3 and the header said 5 x 3 for a 5 x 2 frame (FINDINGS 2026-09-22
|
|
2693
|
+
# B10). Only integer names are tested, so a character vector is never built.
|
|
2694
|
+
if (explicit_rownames) {
|
|
2695
|
+
raw_names <- attr(df, "row.names", exact = TRUE)
|
|
2696
|
+
if (is.integer(raw_names) && identical(raw_names, seq_len(total_rows))) explicit_rownames <- FALSE
|
|
2697
|
+
}
|
|
2299
2698
|
total_cols <- data_cols + as.integer(explicit_rownames)
|
|
2300
2699
|
data_col_cap <- max(0L, preview_cols - as.integer(explicit_rownames))
|
|
2301
2700
|
shown_cols <- if (data_cols && data_col_cap) {
|
|
@@ -2384,11 +2783,26 @@ emit_dataframe <- function(id, df, source = NULL) {
|
|
|
2384
2783
|
columns = I(names(head_df)),
|
|
2385
2784
|
types = I(source_types),
|
|
2386
2785
|
nrow = total_rows, ncol = total_cols,
|
|
2786
|
+
# The frame's OWN width: row names are labels, not a variable, so the
|
|
2787
|
+
# "n x m" a reader sees is nrow x dataCols (mtcars is 32 x 11, not 12).
|
|
2788
|
+
# `ncol` keeps counting the displayed row-name column, which is what the
|
|
2789
|
+
# column pager and `truncated` measure against.
|
|
2790
|
+
dataCols = data_cols,
|
|
2387
2791
|
shown = nrow(head_df), shownCols = ncol(head_df),
|
|
2388
2792
|
truncated = total_rows > nrow(head_df) || total_cols > ncol(head_df),
|
|
2389
2793
|
# jsonlite drops a NULL, so a frame with no name is byte-identical to what
|
|
2390
2794
|
# this emitted before the field existed.
|
|
2391
2795
|
source = source,
|
|
2796
|
+
# How many significant digits this document asked its numbers to be SHOWN
|
|
2797
|
+
# with. The values on the wire stay full precision — the page exports and
|
|
2798
|
+
# copies from them, and rounding here would write 0 for 1.2e-5 the way
|
|
2799
|
+
# jsonlite's own digits = 4 once did. So `options(digits = 3)` becomes a
|
|
2800
|
+
# display instruction the table renderer honours, instead of a call that
|
|
2801
|
+
# looks like configuration and changes nothing: auto-printing a data.frame
|
|
2802
|
+
# never passes through print.data.frame, which is what would have applied
|
|
2803
|
+
# it. NULL (dropped by jsonlite) whenever the document left R's default of
|
|
2804
|
+
# 7 alone, so an untouched notebook's frames are unchanged.
|
|
2805
|
+
digits = display_digits(),
|
|
2392
2806
|
rows = head_df
|
|
2393
2807
|
))
|
|
2394
2808
|
invisible(NULL)
|
|
@@ -2457,7 +2871,7 @@ widget_standalone_html <- function(w, fit = FALSE) {
|
|
|
2457
2871
|
"<style>html,body{margin:0;padding:0;height:100%;}</style>"
|
|
2458
2872
|
}
|
|
2459
2873
|
fit_js <- if (fit) paste0(
|
|
2460
|
-
"<script>(function(){var r=function(){try{parent.postMessage({
|
|
2874
|
+
"<script>(function(){var r=function(){try{parent.postMessage({beatrinaHtmlHeight:",
|
|
2461
2875
|
"Math.ceil(document.documentElement.getBoundingClientRect().height)},'*')}catch(e){}};",
|
|
2462
2876
|
"window.addEventListener('load',r);if(window.ResizeObserver){new ResizeObserver(r)",
|
|
2463
2877
|
".observe(document.documentElement)}setTimeout(r,0);setTimeout(r,250)})()</script>") else ""
|
|
@@ -2485,7 +2899,7 @@ widget_standalone_html <- function(w, fit = FALSE) {
|
|
|
2485
2899
|
#' when `v` is not HTML.
|
|
2486
2900
|
rich_html_of <- function(v) {
|
|
2487
2901
|
if (inherits(v, "htmlwidget")) return(list(x = v, kind = "widget"))
|
|
2488
|
-
if (inherits(v, "
|
|
2902
|
+
if (inherits(v, "beatrina_html")) return(list(x = htmltools::HTML(unclass(v)), kind = "html"))
|
|
2489
2903
|
if (inherits(v, c("shiny.tag", "shiny.tag.list", "html"))) return(list(x = v, kind = "html"))
|
|
2490
2904
|
if (inherits(v, "knit_asis")) return(list(x = htmltools::HTML(paste(as.character(v), collapse = "\n")), kind = "html"))
|
|
2491
2905
|
if (inherits(v, "knitr_kable") && identical(attr(v, "format"), "html")) {
|
|
@@ -2667,7 +3081,7 @@ apply_fn_breaks <- function() {
|
|
|
2667
3081
|
suppressMessages(trace(
|
|
2668
3082
|
h$name,
|
|
2669
3083
|
tracer = bquote({
|
|
2670
|
-
.
|
|
3084
|
+
.beatrina_debug_entered(.(file), .(line), "breakpoint")
|
|
2671
3085
|
browser()
|
|
2672
3086
|
}),
|
|
2673
3087
|
at = h$at, where = h$env, print = FALSE))
|
|
@@ -2731,7 +3145,7 @@ debug_stack <- function(calls, frames, max_frames = 40L) {
|
|
|
2731
3145
|
# frame's environment holds the TRACER EXPRESSION as an unforced promise —
|
|
2732
3146
|
# mget() forces what it reads, so describing that frame re-entered the
|
|
2733
3147
|
# tracer recursively (a second paused frame, a browser "Called from: mget").
|
|
2734
|
-
ours <- "^(\\.
|
|
3148
|
+
ours <- "^(\\.beatrina_debug_entered|\\.beatrina_debug_where|\\.doTrace|browser\\(|eval\\(expr|eval\\.parent|Reduce\\(|\\{)"
|
|
2735
3149
|
while (to >= from && grepl(ours, texts[[to]])) to <- to - 1L
|
|
2736
3150
|
if (to < from) return(list())
|
|
2737
3151
|
idx <- seq.int(from, to)
|
|
@@ -2758,7 +3172,7 @@ debug_stack <- function(calls, frames, max_frames = 40L) {
|
|
|
2758
3172
|
#'
|
|
2759
3173
|
#' THE HARNESS IS TRIMMED. The bottom frames are this file's own
|
|
2760
3174
|
#' (`run_cell`, `withCallingHandlers`, the `lapply` over expressions) and
|
|
2761
|
-
#' showing them teaches the reader that their error came from
|
|
3175
|
+
#' showing them teaches the reader that their error came from Beatrina. Frames
|
|
2762
3176
|
#' are dropped up to and including the last `eval(e, globalenv())`, which is
|
|
2763
3177
|
#' the boundary between our code and theirs.
|
|
2764
3178
|
#'
|
|
@@ -2822,7 +3236,7 @@ capture_trace <- function(max_frames = 40L) {
|
|
|
2822
3236
|
#' The narrow message fallback covers older R releases. In both cases the
|
|
2823
3237
|
#' allow-list is deliberately the same one used by `package_action`, so an
|
|
2824
3238
|
#' error message can never become code or an arbitrary install target.
|
|
2825
|
-
|
|
3239
|
+
beatrina_missing_package <- function(error) {
|
|
2826
3240
|
valid <- function(value) {
|
|
2827
3241
|
is.character(value) && length(value) == 1L && !is.na(value) &&
|
|
2828
3242
|
grepl("^[A-Za-z][A-Za-z0-9.]*$", value)
|
|
@@ -2850,12 +3264,12 @@ run_cell <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
2850
3264
|
# one established outside the cell's own tryCatch, so the cell's exiting
|
|
2851
3265
|
# handlers, being inner, are still the ones that take a real Stop.
|
|
2852
3266
|
withCallingHandlers(run_cell_impl(id, source, dims, srcname),
|
|
2853
|
-
interrupt = function(i) if (
|
|
3267
|
+
interrupt = function(i) if (beatrina_interrupt_is_stray(id)) beatrina_resume_if_stray(i))
|
|
2854
3268
|
}
|
|
2855
3269
|
run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
2856
3270
|
stopifnot(is.character(source), length(source) == 1L)
|
|
2857
3271
|
# First: a signal that arrived between commands must not end THIS cell.
|
|
2858
|
-
|
|
3272
|
+
beatrina_drain_stray_interrupt(id)
|
|
2859
3273
|
# The srcname is the chunk's identity in the debugger: functions defined
|
|
2860
3274
|
# here carry it in their srcrefs, which is what lets findLineNum resolve
|
|
2861
3275
|
# "chunk:<id>#line" to a function and a step. Wire-supplied; anything not a
|
|
@@ -2892,7 +3306,7 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
2892
3306
|
status <- "ok"
|
|
2893
3307
|
detail <- NULL
|
|
2894
3308
|
missing_package <- NULL
|
|
2895
|
-
plot_dir <- tempfile("
|
|
3309
|
+
plot_dir <- tempfile("beatrina-plots-")
|
|
2896
3310
|
dir.create(plot_dir)
|
|
2897
3311
|
seen <- character(0)
|
|
2898
3312
|
# Asked for vector, cannot give it: SAY SO. Falling back to a raster the
|
|
@@ -2903,7 +3317,7 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
2903
3317
|
emit(list(type = "stream", id = id, kind = "warning",
|
|
2904
3318
|
text = paste("Vector output is not available in this R —",
|
|
2905
3319
|
"install the svglite package (or XQuartz, for Cairo)",
|
|
2906
|
-
"and restart. Drawing at", dims$res
|
|
3320
|
+
"and restart. Drawing at", dim_or(dims$res, "res"),
|
|
2907
3321
|
"dpi instead.\n")))
|
|
2908
3322
|
}
|
|
2909
3323
|
|
|
@@ -2950,9 +3364,9 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
2950
3364
|
} else {
|
|
2951
3365
|
NA_integer_
|
|
2952
3366
|
}
|
|
2953
|
-
# Stop, read at the boundary (
|
|
3367
|
+
# Stop, read at the boundary (beatrina_stop_requested): the line after a
|
|
2954
3368
|
# busy call that no signal could interrupt does not run.
|
|
2955
|
-
|
|
3369
|
+
beatrina_stop_if_requested(id)
|
|
2956
3370
|
# Where R is, for the page's progress bar (RStudio's green line
|
|
2957
3371
|
# down the chunk): one frame per top-level expression, BEFORE it
|
|
2958
3372
|
# runs, naming the lines it spans — so a 40-second model fit shows
|
|
@@ -2970,7 +3384,7 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
2970
3384
|
res <- if (!is.na(at_line) && at_line %in% bp_lines) {
|
|
2971
3385
|
wrapped <- as.call(list(
|
|
2972
3386
|
as.name("{"),
|
|
2973
|
-
bquote(.
|
|
3387
|
+
bquote(.beatrina_debug_entered(.(srcname), .(at_line), "breakpoint")),
|
|
2974
3388
|
quote(browser()),
|
|
2975
3389
|
e))
|
|
2976
3390
|
withVisible(eval(wrapped, globalenv()))
|
|
@@ -3008,11 +3422,11 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
3008
3422
|
}
|
|
3009
3423
|
}))
|
|
3010
3424
|
# …and after the last expression: a Stop that arrived while it ran ends the cell interrupted.
|
|
3011
|
-
|
|
3425
|
+
beatrina_stop_if_requested(id)
|
|
3012
3426
|
},
|
|
3013
3427
|
# The stray-signal rule (see run_cell), established INSIDE the cell's own
|
|
3014
3428
|
# tryCatch so it is asked before the exiting handler below can unwind.
|
|
3015
|
-
interrupt = function(i) if (
|
|
3429
|
+
interrupt = function(i) if (beatrina_interrupt_is_stray(id)) beatrina_resume_if_stray(i),
|
|
3016
3430
|
warning = function(w) {
|
|
3017
3431
|
emit(list(type = "stream", id = id, kind = "warning",
|
|
3018
3432
|
text = conditionMessage(w)))
|
|
@@ -3035,7 +3449,7 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
3035
3449
|
# dispatch loop and zombie the worker; invoking this restart instead
|
|
3036
3450
|
# unwinds the browser and the rest of the cell, lands here, and the cell
|
|
3037
3451
|
# reports itself stopped like any interrupt.
|
|
3038
|
-
|
|
3452
|
+
beatrina_abort_cell = function() {
|
|
3039
3453
|
status <<- "interrupted"
|
|
3040
3454
|
detail <<- "Stopped from the debugger"
|
|
3041
3455
|
}
|
|
@@ -3043,7 +3457,7 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
3043
3457
|
error = function(e) {
|
|
3044
3458
|
status <<- "error"
|
|
3045
3459
|
detail <<- conditionMessage(e)
|
|
3046
|
-
missing_package <<-
|
|
3460
|
+
missing_package <<- beatrina_missing_package(e)
|
|
3047
3461
|
# A parse error has no stack and no expression index; its position comes
|
|
3048
3462
|
# from the message instead, exactly as the analyzer reads it.
|
|
3049
3463
|
emit(list(type = "traceback", id = id,
|
|
@@ -3082,13 +3496,13 @@ run_cell_impl <- function(id, source, dims = NULL, srcname = NULL) {
|
|
|
3082
3496
|
#' on to the next line unless a second signal happens to land in the instant
|
|
3083
3497
|
#' between system() returning and that line starting — on Linux it never did
|
|
3084
3498
|
#' (`beatrina check`, 2026-09-16). So the supervisor also writes a flag file,
|
|
3085
|
-
#' `stop-<id>` in
|
|
3499
|
+
#' `stop-<id>` in BEATRINA_STOP_DIR, and the cell reads it at every top-level
|
|
3086
3500
|
#' expression boundary. The flag is removed when read; no directory, no flag.
|
|
3087
3501
|
#'
|
|
3088
3502
|
#' @param id The wire id of the running cell.
|
|
3089
3503
|
#' @return TRUE when a stop was requested (and the flag consumed), else FALSE.
|
|
3090
|
-
|
|
3091
|
-
dir <- Sys.getenv("
|
|
3504
|
+
beatrina_stop_requested <- function(id) {
|
|
3505
|
+
dir <- Sys.getenv("BEATRINA_STOP_DIR", "")
|
|
3092
3506
|
if (!nzchar(dir) || !is.character(id) || length(id) != 1L || is.na(id)) return(FALSE)
|
|
3093
3507
|
flag <- file.path(dir, paste0("stop-", id))
|
|
3094
3508
|
if (!file.exists(flag)) return(FALSE)
|
|
@@ -3100,8 +3514,8 @@ carmar_stop_requested <- function(id) {
|
|
|
3100
3514
|
#' through the same `interrupt` handler a signal reaches.
|
|
3101
3515
|
#' @param id The wire id of the running cell.
|
|
3102
3516
|
#' @return NULL, invisibly, when no stop was requested.
|
|
3103
|
-
|
|
3104
|
-
if (
|
|
3517
|
+
beatrina_stop_if_requested <- function(id) {
|
|
3518
|
+
if (beatrina_stop_requested(id)) {
|
|
3105
3519
|
signalCondition(structure(class = c("interrupt", "condition"),
|
|
3106
3520
|
list(message = "Execution interrupted", call = NULL)))
|
|
3107
3521
|
}
|
|
@@ -3111,23 +3525,23 @@ carmar_stop_if_requested <- function(id) {
|
|
|
3111
3525
|
#' Is a stop flag for run `id` on disk? Read without consuming it.
|
|
3112
3526
|
#' @param id The wire id of the running cell.
|
|
3113
3527
|
#' @return TRUE when the supervisor has asked this run to stop.
|
|
3114
|
-
|
|
3115
|
-
dir <- Sys.getenv("
|
|
3528
|
+
beatrina_stop_pending <- function(id) {
|
|
3529
|
+
dir <- Sys.getenv("BEATRINA_STOP_DIR", "")
|
|
3116
3530
|
if (!nzchar(dir) || !is.character(id) || length(id) != 1L || is.na(id)) return(FALSE)
|
|
3117
3531
|
file.exists(file.path(dir, paste0("stop-", id)))
|
|
3118
3532
|
}
|
|
3119
3533
|
|
|
3120
3534
|
#' Is an interrupt raised inside run `id` NOT this run's Stop?
|
|
3121
3535
|
#'
|
|
3122
|
-
#' Under a supervisor that writes stop flags (
|
|
3536
|
+
#' Under a supervisor that writes stop flags (BEATRINA_STOP_DIR set), every real
|
|
3123
3537
|
#' Stop writes `stop-<id>` BEFORE it sends a signal, so a signal-borne interrupt
|
|
3124
3538
|
#' with no flag for this run was sent for another — one that has already ended.
|
|
3125
3539
|
#' Without a flag folder (an older supervisor) nothing can be told apart, and
|
|
3126
3540
|
#' every interrupt is this run's, as it always was.
|
|
3127
3541
|
#' @param id The wire id of the running cell.
|
|
3128
3542
|
#' @return TRUE only when a flag folder exists and holds no flag for `id`.
|
|
3129
|
-
|
|
3130
|
-
nzchar(Sys.getenv("
|
|
3543
|
+
beatrina_interrupt_is_stray <- function(id) {
|
|
3544
|
+
nzchar(Sys.getenv("BEATRINA_STOP_DIR", "")) && !beatrina_stop_pending(id)
|
|
3131
3545
|
}
|
|
3132
3546
|
|
|
3133
3547
|
#' Resume from an interrupt that belongs to a run that has already ended.
|
|
@@ -3155,7 +3569,7 @@ carmar_interrupt_is_stray <- function(id) {
|
|
|
3155
3569
|
#'
|
|
3156
3570
|
#' @param i The interrupt condition.
|
|
3157
3571
|
#' @return Does not return when a `resume` restart exists; NULL otherwise.
|
|
3158
|
-
|
|
3572
|
+
beatrina_resume_if_stray <- function(i) {
|
|
3159
3573
|
if (!is.null(findRestart("resume"))) invokeRestart("resume")
|
|
3160
3574
|
invisible(NULL)
|
|
3161
3575
|
}
|
|
@@ -3176,13 +3590,13 @@ carmar_resume_if_stray <- function(i) {
|
|
|
3176
3590
|
#' has nothing worth resuming anyway.
|
|
3177
3591
|
#' @param id The wire id of the cell about to run.
|
|
3178
3592
|
#' @return NULL, invisibly.
|
|
3179
|
-
|
|
3593
|
+
beatrina_drain_stray_interrupt <- function(id) {
|
|
3180
3594
|
raised <- tryCatch({
|
|
3181
3595
|
n <- 0L
|
|
3182
3596
|
for (k in seq_len(1200L)) n <- n + 1L
|
|
3183
3597
|
FALSE
|
|
3184
3598
|
}, interrupt = function(i) TRUE)
|
|
3185
|
-
if (isTRUE(raised) &&
|
|
3599
|
+
if (isTRUE(raised) && beatrina_stop_pending(id)) {
|
|
3186
3600
|
signalCondition(structure(class = c("interrupt", "condition"),
|
|
3187
3601
|
list(message = "Execution interrupted", call = NULL)))
|
|
3188
3602
|
}
|
|
@@ -3199,12 +3613,12 @@ carmar_drain_stray_interrupt <- function(id) {
|
|
|
3199
3613
|
#' whole worker down with it, ending the session.
|
|
3200
3614
|
#' @param line One line as read_command returned it.
|
|
3201
3615
|
#' @return The command list, or NULL.
|
|
3202
|
-
|
|
3616
|
+
beatrina_parse_command <- function(line) {
|
|
3203
3617
|
withCallingHandlers({
|
|
3204
3618
|
cmd <- tryCatch(jsonlite::fromJSON(line), error = function(e) NULL)
|
|
3205
3619
|
if (!is.list(cmd) || !is.character(cmd$type) || length(cmd$type) != 1L) return(NULL)
|
|
3206
3620
|
resolve_cmdfile(cmd)
|
|
3207
|
-
}, interrupt =
|
|
3621
|
+
}, interrupt = beatrina_resume_if_stray)
|
|
3208
3622
|
}
|
|
3209
3623
|
|
|
3210
3624
|
#' Read one command line from stdin, tolerating an interrupt that lands while
|
|
@@ -3231,14 +3645,14 @@ read_command <- function(con) {
|
|
|
3231
3645
|
# half-way through when its interrupt fired — the supervisor's `ack` deadline
|
|
3232
3646
|
# (host/worker-plane.mjs) is the answer to that one.
|
|
3233
3647
|
line <- tryCatch(
|
|
3234
|
-
withCallingHandlers(readLines(con, n = 1L, warn = FALSE), interrupt =
|
|
3648
|
+
withCallingHandlers(readLines(con, n = 1L, warn = FALSE), interrupt = beatrina_resume_if_stray),
|
|
3235
3649
|
interrupt = function(i) NA_character_
|
|
3236
3650
|
)
|
|
3237
3651
|
# Strip the supervisor's comment tag; a line without it (older supervisor,
|
|
3238
3652
|
# test harness writing bare NDJSON) passes through untouched.
|
|
3239
3653
|
if (length(line) == 1L && !is.na(line) && nzchar(CMD_PREFIX) &&
|
|
3240
3654
|
startsWith(line, CMD_PREFIX)) {
|
|
3241
|
-
line <- substring(line, nchar(CMD_PREFIX) + 1L)
|
|
3655
|
+
line <- substring(line, nchar(CMD_PREFIX) + 1L, nchar(line))
|
|
3242
3656
|
}
|
|
3243
3657
|
line
|
|
3244
3658
|
}
|
|
@@ -3271,13 +3685,13 @@ resolve_cmdfile <- function(cmd) {
|
|
|
3271
3685
|
# `View(df)` must do what it does in RStudio. Overriding it on the SEARCH PATH
|
|
3272
3686
|
# rather than in globalenv keeps the user's environment clean (the Environment
|
|
3273
3687
|
# pane shows their objects, not ours) while still shadowing utils::View.
|
|
3274
|
-
|
|
3688
|
+
beatrina_tools <- new.env()
|
|
3275
3689
|
# Debug hooks live on the SEARCH PATH, not in this file's private scope, for a
|
|
3276
3690
|
# reason of visibility: a trace() tracer evaluates in the traced function's
|
|
3277
3691
|
# frame, whose lexical chain ends at globalenv() and then the search path —
|
|
3278
3692
|
# the worker's private local() is not on it. Same for expressions typed at a
|
|
3279
|
-
# Browse prompt, which is how .
|
|
3280
|
-
|
|
3693
|
+
# Browse prompt, which is how .beatrina_debug_where is called.
|
|
3694
|
+
beatrina_tools$.beatrina_debug_entered <- function(file, line, reason = "breakpoint") {
|
|
3281
3695
|
# Snapshot FIRST, then drop this function's own frame. Taking sys.calls()
|
|
3282
3696
|
# lazily inside the emit arguments would extend the stack through
|
|
3283
3697
|
# debug_stack/frame_vars themselves, defeat the machinery trimming, and put
|
|
@@ -3291,7 +3705,7 @@ carmar_tools$.carmar_debug_entered <- function(file, line, reason = "breakpoint"
|
|
|
3291
3705
|
locals = frame_vars(parent.frame())))
|
|
3292
3706
|
invisible(NULL)
|
|
3293
3707
|
}
|
|
3294
|
-
|
|
3708
|
+
beatrina_tools$.beatrina_debug_where <- function() {
|
|
3295
3709
|
calls <- sys.calls()
|
|
3296
3710
|
frames <- sys.frames()
|
|
3297
3711
|
n <- length(calls)
|
|
@@ -3306,7 +3720,7 @@ carmar_tools$.carmar_debug_where <- function() {
|
|
|
3306
3720
|
#' @param x HTML as a character vector (joined with newlines) or any value
|
|
3307
3721
|
#' `rich_html_of()` understands.
|
|
3308
3722
|
#' @return Invisibly `x`.
|
|
3309
|
-
|
|
3723
|
+
beatrina_tools$display_html <- function(x) {
|
|
3310
3724
|
rich <- if (is.character(x)) {
|
|
3311
3725
|
list(x = htmltools::HTML(paste(x, collapse = "\n")), kind = "html")
|
|
3312
3726
|
} else {
|
|
@@ -3321,16 +3735,16 @@ carmar_tools$display_html <- function(x) {
|
|
|
3321
3735
|
emit_rich(RUN_STATE$id, rich)
|
|
3322
3736
|
invisible(x)
|
|
3323
3737
|
}
|
|
3324
|
-
|
|
3738
|
+
beatrina_tools$View <- function(x, title = NULL) {
|
|
3325
3739
|
# The LABEL is what the user typed; the FETCH NAME is where the viewer reads
|
|
3326
|
-
# it from. Conflating them titled `View(mtcars)` as `.
|
|
3740
|
+
# it from. Conflating them titled `View(mtcars)` as `.beatrina_view`, because
|
|
3327
3741
|
# mtcars lives in the datasets package rather than the global environment.
|
|
3328
3742
|
label <- if (!is.null(title)) title else deparse(substitute(x))
|
|
3329
|
-
assign(".
|
|
3330
|
-
emit_view("view-request", ".
|
|
3743
|
+
assign(".beatrina_view", x, envir = globalenv())
|
|
3744
|
+
emit_view("view-request", ".beatrina_view", label = label, limit = VIEWER_PAGE_ROWS)
|
|
3331
3745
|
invisible(NULL)
|
|
3332
3746
|
}
|
|
3333
|
-
attach(
|
|
3747
|
+
attach(beatrina_tools, name = "beatrina:tools", warn.conflicts = FALSE)
|
|
3334
3748
|
|
|
3335
3749
|
# Interactive mode reads the console; batch mode opens fd 0 as a connection.
|
|
3336
3750
|
# The console read is what lets browser() prompts and the dispatch loop share
|
|
@@ -3351,7 +3765,7 @@ if (identical(WORKER_MODE, "interactive")) {
|
|
|
3351
3765
|
}
|
|
3352
3766
|
|
|
3353
3767
|
# macOS 26 registers command-line R as a foreground application after Aqua or
|
|
3354
|
-
# AppKit initializes, even when the process was launched by
|
|
3768
|
+
# AppKit initializes, even when the process was launched by Beatrina's UIElement
|
|
3355
3769
|
# helper. The supervisor loads the packaged marker before sourcing this file
|
|
3356
3770
|
# (preventing an initial Dock flash); repeat the transition here, after all
|
|
3357
3771
|
# worker initialization and immediately before `ready`, so any framework that
|
|
@@ -3360,11 +3774,11 @@ if (identical(WORKER_MODE, "interactive")) {
|
|
|
3360
3774
|
# or restarted worker reaches this point automatically.
|
|
3361
3775
|
# OPT-IN — see macos_background_boot in kernel.R. The background transform hides
|
|
3362
3776
|
# the Dock icon but wedges R's console read on a GUI-launched macOS 26 worker,
|
|
3363
|
-
# so it is off unless
|
|
3777
|
+
# so it is off unless BEATRINA_MARK_BACKGROUND=1 is set.
|
|
3364
3778
|
if (identical(unname(Sys.info()[["sysname"]]), "Darwin") &&
|
|
3365
|
-
identical(Sys.getenv("
|
|
3366
|
-
is.loaded("
|
|
3367
|
-
invisible(try(.C("
|
|
3779
|
+
identical(Sys.getenv("BEATRINA_MARK_BACKGROUND", "0"), "1") &&
|
|
3780
|
+
is.loaded("beatrina_mark_background")) {
|
|
3781
|
+
invisible(try(.C("beatrina_mark_background", result = integer(1)), silent = TRUE))
|
|
3368
3782
|
}
|
|
3369
3783
|
|
|
3370
3784
|
# The ready frame says WHICH R this is. A session that silently uses the wrong
|
|
@@ -3402,6 +3816,7 @@ emit(list(type = "ready", pid = Sys.getpid(), r = R.version.string, cwd = getwd(
|
|
|
3402
3816
|
"project_status", "project_action",
|
|
3403
3817
|
"help", "hover", "wd", "files", "sniff",
|
|
3404
3818
|
"import", "readfile", "writefile", "writefiles_atomic", "view", "colstats",
|
|
3819
|
+
"column_values",
|
|
3405
3820
|
"mkdir", "renamepath", "deletepath", "copypath", "revealpath",
|
|
3406
3821
|
"rm", "suspend",
|
|
3407
3822
|
if (identical(WORKER_MODE, "interactive")) "debug_breaks"))))
|
|
@@ -3416,7 +3831,7 @@ emit(list(type = "ready", pid = Sys.getpid(), r = R.version.string, cwd = getwd(
|
|
|
3416
3831
|
# parser's (a late signal, resumed), the dispatcher's (Stop as the cell's own
|
|
3417
3832
|
# outcome) — and the loop around them has the last word: an interrupt that
|
|
3418
3833
|
# escapes an iteration ends that iteration, never the loop, and one that escapes
|
|
3419
|
-
# the loop itself re-enters it through the `
|
|
3834
|
+
# the loop itself re-enters it through the `beatrina_serve_again` restart from a
|
|
3420
3835
|
# global calling handler. Before 2026-09-16 the parse step had no handler at all,
|
|
3421
3836
|
# and a late Stop signal raised there unwound the whole worker script into R's
|
|
3422
3837
|
# top-level prompt — where the `options(error=)` guard ended the process, or,
|
|
@@ -3439,7 +3854,7 @@ emit(list(type = "ready", pid = Sys.getpid(), r = R.version.string, cwd = getwd(
|
|
|
3439
3854
|
# view) catch it themselves, with meaning. The outer handler exists for the
|
|
3440
3855
|
# narrow window where one lands outside those — an uncaught interrupt ends
|
|
3441
3856
|
# the worker script, and the supervisor treats a dead worker as fatal.
|
|
3442
|
-
|
|
3857
|
+
beatrina_dispatch <- function(cmd) {
|
|
3443
3858
|
if (identical(cmd$type, "exec")) {
|
|
3444
3859
|
if (is.null(cmd$document)) run_cell(cmd$id, cmd$source, cmd$dims, cmd$srcname)
|
|
3445
3860
|
else run_document_cell(cmd$id, cmd$source, cmd$document, cmd$dims, cmd$srcname)
|
|
@@ -3487,6 +3902,9 @@ carmar_dispatch <- function(cmd) {
|
|
|
3487
3902
|
if (identical(cmd$type, "colstats")) emit_colstats(cmd$id, cmd$name, cmd$column,
|
|
3488
3903
|
query = cmd$query,
|
|
3489
3904
|
filters = cmd$filters)
|
|
3905
|
+
if (identical(cmd$type, "column_values")) emit_column_values(cmd$id, cmd$name, cmd$column,
|
|
3906
|
+
query = cmd$query,
|
|
3907
|
+
filters = cmd$filters)
|
|
3490
3908
|
if (identical(cmd$type, "rm")) emit_rm(cmd$id, cmd$names)
|
|
3491
3909
|
invisible(NULL)
|
|
3492
3910
|
}
|
|
@@ -3500,7 +3918,7 @@ carmar_dispatch <- function(cmd) {
|
|
|
3500
3918
|
# interrupts around the eval, but one landing in its epilogue (unlink,
|
|
3501
3919
|
# flush, the emit itself) used to escape this loop, end the worker script,
|
|
3502
3920
|
# and take the supervisor's event loop down with it.
|
|
3503
|
-
|
|
3921
|
+
beatrina_fail_frame <- function(cmd, text, outcome = "error") {
|
|
3504
3922
|
id_ok <- is.character(cmd$id) && length(cmd$id) == 1L
|
|
3505
3923
|
if (identical(cmd$type, "exec")) {
|
|
3506
3924
|
if (id_ok) emit(list(type = "done", id = cmd$id, status = outcome,
|
|
@@ -3514,11 +3932,11 @@ carmar_fail_frame <- function(cmd, text, outcome = "error") {
|
|
|
3514
3932
|
#' Serve one command. Returns "eof" when the supervisor has gone, "shutdown"
|
|
3515
3933
|
#' when it said so, NULL after a command or a line that was not one.
|
|
3516
3934
|
#' @param con The command connection (the console in interactive mode).
|
|
3517
|
-
|
|
3935
|
+
beatrina_serve_one <- function(con) {
|
|
3518
3936
|
line <- read_command(con)
|
|
3519
3937
|
if (length(line) == 0L) return("eof") # EOF: supervisor went away
|
|
3520
3938
|
if (is.na(line) || !nzchar(trimws(line))) return(NULL)
|
|
3521
|
-
cmd <-
|
|
3939
|
+
cmd <- beatrina_parse_command(line)
|
|
3522
3940
|
if (is.null(cmd)) return(NULL)
|
|
3523
3941
|
if (identical(cmd$type, "shutdown")) return("shutdown")
|
|
3524
3942
|
# The acknowledgement: the supervisor wrote this command to an idle worker and
|
|
@@ -3529,10 +3947,10 @@ carmar_serve_one <- function(con) {
|
|
|
3529
3947
|
# only wait forever — an exec has no deadline, by design. With it, a command
|
|
3530
3948
|
# that is never acknowledged is failed with a sentence and the queue moves on.
|
|
3531
3949
|
if (is.character(cmd$id) && length(cmd$id) == 1L && !is.na(cmd$id)) emit(list(type = "ack", id = cmd$id))
|
|
3532
|
-
tryCatch(
|
|
3533
|
-
error = function(e)
|
|
3950
|
+
tryCatch(allowInterrupts(beatrina_dispatch(cmd)),
|
|
3951
|
+
error = function(e) beatrina_fail_frame(cmd, paste("command failed:", conditionMessage(e))),
|
|
3534
3952
|
# Cleanup interrupts mean the same thing as interrupts during eval.
|
|
3535
|
-
interrupt = function(i)
|
|
3953
|
+
interrupt = function(i) beatrina_fail_frame(cmd, "Execution interrupted", "interrupted"))
|
|
3536
3954
|
NULL
|
|
3537
3955
|
}
|
|
3538
3956
|
|
|
@@ -3540,9 +3958,9 @@ carmar_serve_one <- function(con) {
|
|
|
3540
3958
|
#' iteration and nothing else.
|
|
3541
3959
|
#' @param con The command connection.
|
|
3542
3960
|
#' @return "eof" or "shutdown", invisibly.
|
|
3543
|
-
|
|
3961
|
+
beatrina_serve <- function(con) {
|
|
3544
3962
|
repeat {
|
|
3545
|
-
outcome <- tryCatch(
|
|
3963
|
+
outcome <- tryCatch(beatrina_serve_one(con), interrupt = function(i) NULL)
|
|
3546
3964
|
if (identical(outcome, "eof") || identical(outcome, "shutdown")) return(invisible(outcome))
|
|
3547
3965
|
}
|
|
3548
3966
|
}
|
|
@@ -3555,13 +3973,18 @@ carmar_serve <- function(con) {
|
|
|
3555
3973
|
# the process, as the `options(error=)` guard does for an error: a worker at
|
|
3556
3974
|
# R's top-level prompt is a zombie the supervisor cannot tell from an idle one.
|
|
3557
3975
|
globalCallingHandlers(interrupt = function(i) {
|
|
3558
|
-
if (!is.null(findRestart("
|
|
3976
|
+
if (!is.null(findRestart("beatrina_serve_again"))) invokeRestart("beatrina_serve_again")
|
|
3559
3977
|
quit(save = "no", status = 70L)
|
|
3560
3978
|
})
|
|
3561
|
-
|
|
3562
|
-
|
|
3563
|
-
|
|
3564
|
-
|
|
3979
|
+
# Signals between commands must not unwind a consumed line or the loop's
|
|
3980
|
+
# restart setup. Only dispatch enables interrupts; run_cell distinguishes a
|
|
3981
|
+
# flagged Stop from a late signal, and its handlers are installed before entry.
|
|
3982
|
+
suspendInterrupts({
|
|
3983
|
+
repeat {
|
|
3984
|
+
outcome <- withRestarts(beatrina_serve(con), beatrina_serve_again = function() NULL)
|
|
3985
|
+
if (!is.null(outcome)) break
|
|
3986
|
+
}
|
|
3987
|
+
})
|
|
3565
3988
|
|
|
3566
3989
|
# stdin() is R's console, not ours to close. And an interactive R does not
|
|
3567
3990
|
# exit when the script does — it would sit at the top-level prompt waiting for
|