beatrina 0.8.6

package/kernel/knitr-run.R

@@ -0,0 +1,245 @@
+# Interactive notebook execution using knitr's PUBLIC cache and option APIs.
+# Sourced into worker.R's private environment. The native evaluator retains
+# breakpoints, interactive input, rich tables, progress and interrupt handling.
+# Only the notebook exec envelope uses this adapter; console exec is unchanged.
+KNIT_DOCS <- new.env(parent = emptyenv())
+KNIT_BASE <- NULL
+KNIT_CAPTURE <- NULL
+KNIT_PROTOCOL <- FALSE
+KNIT_MARKER <- "CARMAR_KNIT_OUTPUT_V1:"
+
+run_document_cell <- function(id, source, document, dims = NULL, srcname = NULL) {
+  KNIT_PROTOCOL <<- TRUE
+  terminal <- list(type = "done", id = id, status = "ok", message = NULL)
+  setup_report <- NULL
+  cache_hit <- FALSE
+  effective <- NULL
+  saved_hooks <- saved_options <- saved_templates <- NULL
+  on.exit({
+    KNIT_CAPTURE <<- NULL
+    KNIT_PROTOCOL <<- FALSE
+    if (!is.null(saved_hooks)) knitr::knit_hooks$restore(saved_hooks)
+    if (!is.null(saved_options)) knitr::opts_chunk$restore(saved_options)
+    if (!is.null(saved_templates)) knitr::opts_template$restore(saved_templates)
+  }, add = TRUE)
+  outcome <- tryCatch({
+    if (!is.list(document) || !is.character(document$id) || length(document$id) != 1L ||
+        !nzchar(document$id)) stop("A notebook run needs its document identity.")
+    for (package in c("knitr", "evaluate")) {
+      if (!requireNamespace(package, quietly = TRUE)) {
+        terminal$missingPackage <- package
+        stop(paste0("Notebook chunk options require ", package, ". Install it from Tools > Packages."))
+      }
+    }
+    saved_options <- knitr::opts_chunk$get()
+    saved_hooks <- knitr::knit_hooks$get()
+    saved_templates <- knitr::opts_template$get()
+    if (is.null(KNIT_BASE)) KNIT_BASE <<- saved_options
+    setup <- if (length(document$setup)) document$setup else NULL
+    if (!is.null(setup) && (!is.list(setup) || !is.character(setup$source) || length(setup$source) != 1L))
+      stop("Invalid setup chunk descriptor.")
+    previous <- KNIT_DOCS[[document$id]]
+    setup_key <- if (is.null(setup)) "" else setup$source
+    if (!is.null(previous) && identical(previous$source, setup_key) &&
+        identical(previous$status, "failed") && !isTRUE(document$isSetup) && !isTRUE(document$retrySetup))
+      stop("Setup previously failed. Fix it or explicitly run the setup chunk before running dependent chunks.")
+    setup_changed <- is.null(previous) || !identical(previous$source, setup_key)
+    opts <- if (setup_changed || is.null(previous$options)) KNIT_BASE else previous$options
+    knitr::opts_chunk$restore(opts)
+
+    # All protocol writes bypass evaluate's output sink. The callback captures
+    # only this run's result frames; debugger/input/progress stay live and are
+    # never cached. A native done frame is held until knitr commits its cache.
+    native <- function(code, options, debug_name, save_figures = TRUE) {
+      frames <- list()
+      native_done <- NULL
+      capture_error <- NULL
+      plot_n <- 0L
+      KNIT_CAPTURE <<- function(frame) {
+        if (!identical(frame$id, id)) return(TRUE)
+        if (!identical(frame$type, "stdout")) evaluate::flush_console()
+        if (identical(frame$type, "progress") && !identical(debug_name, srcname)) {
+          frame$phase <- "setup"
+          emit_wire(frame)
+          return(FALSE)
+        }
+        if (identical(frame$type, "done")) { native_done <<- frame; return(FALSE) }
+        if (!frame$type %in% c("stdout", "stderr", "stream", "plot", "dataframe", "widget", "traceback")) return(TRUE)
+        if (identical(frame$type, "stream") &&
+            ((identical(frame$kind, "warning") && identical(options$warning, FALSE)) ||
+             (identical(frame$kind, "message") && identical(options$message, FALSE)))) return(FALSE)
+        if (identical(frame$type, "stdout") && !is.null(options$comment) && nzchar(options$comment)) {
+          frame$text <- paste0(options$comment, " ", strsplit(frame$text, "\n", fixed = TRUE)[[1L]], collapse = "\n")
+        }
+        if (identical(frame$type, "plot") && save_figures) {
+          plot_n <<- plot_n + 1L
+          suffix <- if (identical(frame$mime, "image/svg+xml")) ".svg" else ".png"
+          target <- paste0(options$fig.path, options$label, "-", plot_n, suffix)
+          tryCatch({
+            dir.create(dirname(target), recursive = TRUE, showWarnings = FALSE)
+            writeBin(jsonlite::base64_dec(frame$data), target)
+            frame$path <- target
+          }, error = function(e) {
+            # Native final plot harvesting deliberately tolerates a failed
+            # device. Do not let that swallow a requested figure-file write
+            # failure and mark this run/cache successful.
+            capture_error <<- paste0("Could not write figure ", target, ": ", conditionMessage(e))
+          })
+        }
+        frames[[length(frames) + 1L]] <<- frame
+        # Re-emit the transformed copy, not the original frame.
+        if (!identical(options$include, FALSE) || identical(frame$type, "traceback")) emit_wire(frame)
+        FALSE
+      }
+      on.exit(KNIT_CAPTURE <<- NULL, add = TRUE)
+      dpi <- options$dpi
+      width <- options$fig.width
+      height <- options$fig.height
+      valid_dimension <- function(x) is.numeric(x) && length(x) == 1L && is.finite(x) && x > 0
+      if (!all(vapply(list(dpi, width, height), valid_dimension, logical(1))))
+        stop("dpi, fig.width and fig.height must each be one positive finite number.")
+      if (width * dpi > 20000 || height * dpi > 20000 || width * height * dpi^2 > 1e8)
+        stop("The requested figure is too large (maximum 20,000 pixels per edge / 100 megapixels). Reduce its size or dpi.")
+      native_dims <- list(width = width * dpi, height = height * dpi, res = dpi,
+                          format = if (identical(options$dev, "svg")) "svg" else "png")
+      runner <- function() {
+        RUN_STATE$capture_depth <- sink.number()
+        on.exit(RUN_STATE$capture_depth <- NULL, add = TRUE)
+        run_cell(id, code, native_dims, debug_name)
+      }
+      evaluate::evaluate("runner()", envir = environment(), new_device = FALSE,
+        stop_on_error = 2L, output_handler = evaluate::new_output_handler(
+          text = function(text) { emit(list(type = "stdout", id = id, text = sub("\n$", "", text))); invisible(NULL) }))
+      if (is.null(native_done)) stop("The native evaluator did not finish this chunk.")
+      if (!identical(native_done$status, "ok")) {
+        terminal <<- native_done
+        stop(native_done$message %||% paste("Chunk", native_done$status), call. = FALSE)
+      }
+      if (!is.null(capture_error)) stop(capture_error, call. = FALSE)
+      frames
+    }
+
+    if (!is.null(setup) && (setup_changed || isTRUE(document$isSetup) || identical(previous$status, "failed"))) {
+      # Invalidate BEFORE executing: a failed partial setup must never leave a
+      # previous Ready snapshot available to dependent chunks.
+      KNIT_DOCS[[document$id]] <- NULL
+      setup_report <- list(source = setup$source, srcname = setup$srcname, status = "running")
+      emit(list(type = "setup", id = id, source = setup$source, srcname = setup$srcname, status = "running"))
+      setup_options <- modifyList(KNIT_BASE, list(cache = FALSE, include = FALSE, label = "setup"))
+      native(setup$source, setup_options, setup$srcname, save_figures = FALSE)
+      opts <- knitr::opts_chunk$get()
+      KNIT_DOCS[[document$id]] <- list(source = setup_key, options = opts)
+      setup_report$status <- "ok"
+    } else if (is.null(setup)) {
+      KNIT_DOCS[[document$id]] <- list(source = "", options = opts)
+    }
+    if (!isTRUE(document$isSetup)) {
+      label <- document$label
+      if (!is.character(label) || length(label) != 1L || !grepl("^[A-Za-z0-9_.-]+$", label))
+        stop("Use a unique chunk label containing letters, numbers, dots, hyphens or underscores.")
+      knitr::opts_chunk$restore(opts)
+      chunk_options <- document$options %||% list()
+      expressions <- document$expressions %||% list()
+      if (!is.list(chunk_options) || !is.list(expressions)) stop("Invalid chunk options.")
+      # Parsed expression source is evaluated only at Run, in the real R
+      # environment, just as a knitr header is. Menu opening never evaluates R.
+      for (key in names(expressions)) chunk_options[key] <- list(eval(parse(text = expressions[[key]]), globalenv()))
+      for (key in names(chunk_options)) if (grepl("-", key, fixed = TRUE)) {
+        alias <- gsub("-", ".", key, fixed = TRUE)
+        if (!alias %in% names(chunk_options)) chunk_options[alias] <- chunk_options[key]
+        chunk_options[[key]] <- NULL
+      }
+      # Older hand-authored notebooks stored device dimensions separately
+      # from chunk headers. Preserve those until a document setup or explicit
+      # figure option takes ownership; do not reset existing plots to 7 x 7.
+      if (is.null(setup) && is.list(dims) && is.numeric(dims$res) && length(dims$res) == 1L && is.finite(dims$res) && dims$res > 0) {
+        legacy <- list(fig.width = dims$width / dims$res, fig.height = dims$height / dims$res, dpi = dims$res)
+        for (key in names(legacy)) if (is.null(chunk_options[[key]]) && identical(opts[[key]], KNIT_BASE[[key]]) && length(legacy[[key]]) == 1L)
+          chunk_options[[key]] <- legacy[[key]]
+      }
+      chunk_options$label <- label
+      # Errors/interruption never become successful cached results.
+      chunk_options$error <- FALSE
+      chunk_options$engine <- "R"
+      chunk_options$carmar.adapter <- 1L
+      chunk_options$carmar.document <- if (is.character(document$cacheId) && length(document$cacheId) == 1L && nzchar(document$cacheId)) document$cacheId else document$id
+      chunk_options$carmar.setup <- setup_key
+      chunk_options$carmar.cwd <- getwd()
+      # Selection runs are native, uncached, but still inherit setup defaults.
+      if (isTRUE(document$selection)) chunk_options$cache <- FALSE
+      if (!is.null(dims$format) && identical(dims$format, "svg")) chunk_options$dev <- "svg"
+      # Local options are a public knitr template, not opts_chunk globals.
+      # Code reading opts_chunk sees document defaults; opts_current sees its
+      # effective local options. A local override never leaks to the next cell.
+      knitr::opts_template$set(.carmar_interactive = chunk_options)
+      merged <- modifyList(opts, chunk_options, keep.null = TRUE)
+      if (!is.language(merged$eval) && (!is.logical(merged$eval) || length(merged$eval) != 1L || is.na(merged$eval)))
+        stop("Interactive eval must be TRUE or FALSE. Use a full knitr render for expression-index selections.")
+      requested_cache <- merged$cache
+      if (!isTRUE(requested_cache) && !identical(requested_cache, FALSE) && !identical(requested_cache, 3) && !identical(requested_cache, 3L))
+        stop("Interactive caching supports cache=TRUE, FALSE or 3. Use a full knitr render for cache levels 1 and 2.")
+      effective <- merged[c("warning", "message", "comment", "fig.path", "dpi", "fig.width", "fig.height", "cache", "cache.path", "include", "eval")]
+      collected <- list()
+      evaluated <- FALSE
+      knitr::knit_hooks$set(evaluate = function(code, envir, ...) {
+        evaluated <<- TRUE
+        current <- knitr::opts_current$get()
+        if (!is.logical(current$eval) || length(current$eval) != 1L || is.na(current$eval))
+          stop("Interactive eval must resolve to TRUE or FALSE; numeric expression selections require a full knitr render.")
+        effective <<- current[intersect(names(current), c("warning", "message", "comment", "fig.path", "dpi", "fig.width", "fig.height", "cache", "cache.path", "include", "eval"))]
+        collected <<- native(source, current, srcname)
+        KNIT_DOCS[[document$id]] <- list(source = setup_key, options = knitr::opts_chunk$get())
+        list()
+      }, chunk = function(x, options) {
+        paste0(KNIT_MARKER, jsonlite::base64_enc(charToRaw(jsonlite::toJSON(collected,
+          auto_unbox = TRUE, null = "null", na = "null", digits = NA))))
+      })
+      # Source stays the REAL chunk source so knitr discovers/cache-restores
+      # the correct R objects. The evaluator hook retains CarmaR's native path.
+      fence <- paste(rep("`", max(3L, max(nchar(regmatches(source, gregexpr("`+", source))[[1L]]), 0L) + 1L)), collapse = "")
+      input <- paste0(fence, "{r ", label, ", opts.label='.carmar_interactive'}\n", source, "\n", fence, "\n")
+      output <- withCallingHandlers(knitr::knit(text = input, envir = globalenv(), quiet = TRUE),
+        message = function(m) {
+          # The native traceback already names the real chunk/source. knitr's
+          # synthetic one-chunk wrapper would add "Quitting from :1-3", which
+          # is not a location the user can open.
+          if (grepl("^\\s*Quitting from", conditionMessage(m))) invokeRestart("muffleMessage")
+        })
+      if (!evaluated && identical(output, input)) stop("knitr did not recognize the generated R chunk fence.")
+      cache_hit <- !evaluated && !identical(merged$eval, FALSE)
+      if (!evaluated && identical(merged$eval, FALSE)) {
+        terminal$status <- "skipped"
+        terminal$message <- "eval=FALSE in the document defaults — this chunk was not evaluated."
+        terminal$reason <- terminal$message
+      }
+      if (cache_hit && startsWith(trimws(output), KNIT_MARKER)) {
+        payload <- substring(trimws(output), nchar(KNIT_MARKER) + 1L)
+        restored <- jsonlite::fromJSON(rawToChar(jsonlite::base64_dec(payload)), simplifyVector = FALSE)
+        for (frame in restored) { frame$id <- id; emit(frame) }
+      }
+    }
+    NULL
+  }, interrupt = function(e) {
+    terminal$status <<- "interrupted"; terminal$message <<- "Interrupted"
+  }, error = function(e) {
+    if (identical(terminal$status, "ok")) terminal$status <<- "error"
+    terminal$message <<- conditionMessage(e)
+    if (!is.null(setup_report) && identical(setup_report$status, "running")) {
+      setup_report$status <<- terminal$status
+      KNIT_DOCS[[document$id]] <- list(source = setup_report$source, status = "failed")
+      terminal$message <<- paste0("Setup chunk failed; dependent chunk was not run. ", terminal$message)
+    }
+  })
+  KNIT_CAPTURE <<- NULL
+  terminal$cwd <- getwd()
+  terminal$setup <- setup_report
+  terminal$cacheHit <- cache_hit
+  terminal$effectiveOptions <- effective
+  if (is.list(document)) terminal$execution <- list(
+    source = if (isTRUE(document$isSetup) && is.list(document$setup)) document$setup$source else source,
+    setupSource = if (is.list(document$setup)) document$setup$source %||% "" else "",
+    optionsKey = document$optionsKey,
+    full = !isTRUE(document$selection))
+  emit(terminal)
+  invisible(NULL)
+}