@damurka/jovian 0.1.0

package/packages/hera/R/inspect.R

@@ -0,0 +1,73 @@
+inspect <- function(code, cursor_pos, eval_env = rlang::global_env()) {
+    # This is the approach used in IRkernel, it would perhaps
+    # be better to use parsing instead, e.g. with the internal R
+    # parser, but the expression has to be complete, or a more
+    # forgiving parser, e.g. tree-sitter and the grammar for R:
+    # https://github.com/r-lib/tree-sitter-r/tree/next
+
+    # Get token under the `cursor_pos`.
+    # Since `.guessTokenFromLine()` does not check the characters after `cursor_pos`
+    # check them by a loop. Use get since R CMD check does not like :::
+    token <- ''
+    for (i in seq(cursor_pos, nchar(code))) {
+        token_candidate <- utils___guessTokenFromLine(code, i)
+        if (nchar(token_candidate) == 0) break
+        token <- token_candidate
+    }
+
+    # Function to add a section to content.
+    title_templates <- list(
+        'text/plain' = '# %s:\n',
+        'text/html' = '<h1>%s:</h1>\n'
+    )
+
+    add_new_section <- function(data, section_name, new_data) {
+        for (mime in names(title_templates)) {
+            new_content <- new_data[[mime]]
+            if (is.null(new_content)) next
+            title <- sprintf(title_templates[[mime]], section_name)
+            # use paste0 since sprintf cannot deal with format strings > 8192 bytes
+            data[[mime]] <- paste0(data[[mime]], title, new_content, '\n', sep = '\n')
+        }
+        return(data)
+    }
+
+    data <- namedlist()
+    if (nchar(token) != 0) {
+        # In many cases `get(token)` works, but it does not
+        # in the cases such as `token` is a numeric constant or a reserved word.
+        # Therefore `eval()` is used here.
+        obj <- tryCatch(eval(parse(text = token), envir = eval_env), error = function(e) NULL)
+        class_data <- if (!is.null(obj)) IRdisplay::prepare_mimebundle(class(obj))$data
+        print_data <- if (!is.null(obj)) IRdisplay::prepare_mimebundle(obj)$data
+
+        # `help(token)` is not used here because it does not works
+        # in the cases `token` is in `pkg::topic`or `pkg:::topic` form.
+        help_data <- tryCatch({
+            help_obj <- eval(parse(text = paste0('?', token)))
+            if (length(help_obj) > 0) {
+                IRdisplay::prepare_mimebundle(help_obj)$data
+            }
+        }, error = function(e) NULL)
+
+        # only show help if we have a function
+        if ('function' %in% class(obj) && !is.null(help_data)) {
+            data <- help_data
+        } else {
+            # any of those that are NULL are automatically skipped
+            data <- add_new_section(data, 'Class attribute', class_data)
+            data <- add_new_section(data, 'Printed form', print_data)
+            data <- add_new_section(data, 'Help document', help_data)
+        }
+    }
+
+    for (mime in names(data)) {
+        data[[mime]] <- unbox(data[[mime]])
+    }
+
+    list(found = length(data) > 0L, 
+        # data = toJSON(data, auto_unbox = TRUE), 
+        data = enc2utf8(toJSON(data, auto_unbox = TRUE)),
+        metadata = NULL
+    )
+}

package/packages/hera/R/log.R

@@ -0,0 +1,14 @@
+
+logger <- function(level, name) {
+    function(...) {
+        if (isTRUE(getOption('jupyter.log_level') >= level)) {
+            msg <- glue(...)
+            hera_dot_call("elara_log", name, msg)
+        }
+        invisible(NULL)
+    }
+}
+
+log_debug <- logger(3L, 'DEBUG')
+log_info  <- logger(2L, 'INFO')
+log_error <- logger(1L, 'ERROR')

package/packages/hera/R/mime_bundle.R

@@ -0,0 +1,65 @@
+#' MIME types supported by an object
+#'
+#' @param x an object
+#'
+#' @examples
+#' mime_types(letters)
+#' mime_types(mtcars)
+#'
+#' @return a character vector of its supported mime types
+#' @export
+mime_types <- function(x) {
+  UseMethod("mime_types")
+}
+
+#' @export
+mime_types.default <- function(x) {
+  "text/plain"
+}
+
+#' @export
+mime_types.htmlwidget <- function(x) {
+  c("text/plain", "text/html")
+}
+
+#' @export
+mime_types.shiny.tag.list <- function(x) {
+  c("text/plain", "text/html")
+}
+
+#' @export
+mime_types.shiny.tag <- function(x) {
+  c("text/plain", "text/html")
+}
+
+# R help objects. Without this, mime_types.default returns "text/plain", which
+# repr::repr_text renders via tools::Rd2txt. Rd2txt emits nroff overstrike
+# ("_\bX" underline, "X\bX" bold), and Jupyter's stdout stream does not
+# interpret backspaces, so ?lm displays raw "_ l_ m" garbage. Advertising
+# text/html lets the frontend pick the HTML rendering instead.
+#' @export
+mime_types.help_files_with_topic <- function(x) {
+  c("text/plain", "text/html")
+}
+
+#' bundle an object
+#'
+#' @param x an object
+#' @param mimetypes mime types
+#' @param ... extra currently unused parameters
+#'
+#' @examples
+#' mime_bundle(letters)
+#'
+#' @seealso IRdisplay::prepare_mimebundle which this currently wraps around
+#'
+#' @export
+mime_bundle <- function(x, mimetypes = mime_types(x), ...) {
+  UseMethod("mime_bundle")
+}
+
+#' @importFrom IRdisplay prepare_mimebundle
+#' @export
+mime_bundle.default <- function(x, mimetypes = mime_types(x), ...) {
+  prepare_mimebundle(x, mimetypes = mimetypes, ...)
+}

package/packages/hera/R/routines.R

@@ -0,0 +1,86 @@
+publish_stream <- function(name, text) {
+  hera_dot_call("elara_publish_stream", name, text)
+}
+
+# jsonlite::toJSON() base64-encodes raw vectors (e.g. plot image bytes) via
+# jsonlite::base64_enc(), which always MIME-wraps its output with embedded
+# newlines and offers no argument to disable it. Those newlines survive
+# JSON string-escaping as literal "\n" sequences and, once unescaped by a
+# downstream JSON parser, produce a base64 payload containing real newline
+# characters -- which a strict (non-whitespace-tolerant) base64 decoder on
+# the receiving end will reject. Recursively re-encode any raw elements
+# with jsonlite's own encoder and strip the wrapping newlines before they
+# ever reach toJSON(), so raw data becomes a plain, unwrapped base64 string.
+sanitize_raw_for_json <- function(x) {
+  if (is.raw(x)) {
+    gsub("\n", "", jsonlite::base64_enc(x), fixed = TRUE)
+  } else if (is.list(x)) {
+    lapply(x, sanitize_raw_for_json)
+  } else {
+    x
+  }
+}
+
+#' Display data
+#'
+#' @param data data to display
+#' @param metadata potential metadata
+#'
+#' @examples
+#' \dontrun{
+#'   display_data(mtcars)
+#' }
+#'
+#' @export
+display_data <- function(data = NULL, metadata = NULL) {
+  invisible(hera_dot_call("elara_display_data",
+                          enc2utf8(toJSON(sanitize_raw_for_json(data), auto_unbox = TRUE)),
+                          enc2utf8(toJSON(metadata, auto_unbox = TRUE))))
+}
+
+update_display_data <- function(data = NULL, metadata = NULL) {
+  invisible(hera_dot_call("elara_update_display_data",
+                          enc2utf8(toJSON(sanitize_raw_for_json(data), auto_unbox = TRUE)),
+                          enc2utf8(toJSON(metadata, auto_unbox = TRUE))))
+}
+
+kernel_info_request <- function() {
+  hera_dot_call("elara_kernel_info_request")
+}
+
+
+#' Clear output
+#'
+#' @param wait Should this wait
+#'
+#' @examples
+#' \dontrun{
+#'   clear_output()
+#' }
+#'
+#' @return NULL invisibly
+#' @export
+clear_output <- function(wait = FALSE) {
+  invisible(hera_dot_call("elara_clear_output", isTRUE(wait)))
+}
+
+is_complete_request <- function(code) {
+  hera_dot_call("elara_is_complete_request", code)
+}
+
+#' View
+#'
+#' @param x something to display
+#' @param title title of the display
+#'
+#' @examples
+#' \dontrun{
+#'   View(mtcars)
+#' }
+#'
+#' @export
+View <- function(x, title) {
+  if (!missing(title)) IRdisplay::display_text(title)
+  IRdisplay::display(x)
+  invisible(x)
+}

package/packages/hera/R/utils.R

@@ -0,0 +1,32 @@
+# borrowed from IRkernel
+get_os <- function() {
+    switch(.Platform$OS.type,
+        windows = 'win',
+        unix = if (identical(Sys.info()[['sysname']], 'Darwin')) 'osx'
+               else 'unix'
+    )
+}
+
+namedlist <- function() {
+    `names<-`(list(), character())
+}
+
+set_last_value <- function(obj, visible) {
+    the$last_visible <- visible
+
+    get("unlockBinding", envir = baseenv())(".Last.value", .BaseNamespaceEnv)
+    assign(".Last.value", obj, .BaseNamespaceEnv)
+    get("lockBinding", envir = baseenv())(".Last.value", .BaseNamespaceEnv)
+}
+
+# borrowed from IRkernel
+plot_builds_upon <- function(prev, current) {
+    if (is.null(prev)) {
+        return(TRUE)
+    }
+
+    lprev <- length(prev[[1]])
+    lcurrent <- length(current[[1]])
+
+    lcurrent >= lprev && identical(current[[1]][1:lprev], prev[[1]][1:lprev])
+}

package/packages/hera/R/zzz.R

@@ -0,0 +1,128 @@
+#' @importFrom grDevices pdf png
+#' @importFrom jsonlite toJSON unbox fromJSON
+#' @importFrom utils head tail capture.output
+#' @importFrom R6 R6Class
+#' @importFrom rlang caller_env
+#' @import glue
+NULL
+
+print_vignette <- function(x, ...) {
+  file <- x$PDF
+  if (nzchar(file) == 0) {
+    warning(gettextf("vignette %s has no PDF/HTML", sQuote(x$Topic)), call. = FALSE, domain = NA)
+    return(invisible(x))
+  }
+
+  ext <- tolower(tools::file_ext(file))
+  if (ext == "pdf") {
+    warning("can't display pdf vignette yet")
+    return(invisible(x))
+  }
+
+  if (ext == "html") {
+    html <- readLines(file.path(x$Dir, "doc", file))
+
+    display_data(
+      data = list(
+        "text/html" = paste(html, collapse = "\n")
+      ),
+      metadata = list(
+        "text/html" = list(isolated = TRUE)
+      )
+    )
+  }
+
+  invisible(x)
+}
+
+NAMESPACE <- environment()
+the <- NULL
+
+.onLoad <- function(libname, pkgname) {
+    # Elara verification/handshake now happens via is_elara()/hera_dot_call()
+    # below, not here -- this used to be a bare TODO for that, predating
+    # those functions.
+    NAMESPACE$the <- new.env()
+    the$frame_cell_execute <- NULL
+    the$last_plot <- NULL
+    the$last_visible <- TRUE
+    the$last_error <- NULL
+
+    ns_utils <- asNamespace("utils")
+    get("unlockBinding", envir = baseenv())("print.vignette", ns_utils)
+
+    assign("print.vignette", print_vignette, ns_utils)
+    get("lockBinding", envir = baseenv())("print.vignette", ns_utils)
+
+    NAMESPACE$CommManager <- CommManagerClass$new()
+
+    init_options()   
+}
+
+init_options <- function() {
+  options(
+    device = get_null_device(),
+    cli.num_colors = 256L,
+    jupyter.plot_mimetypes = c('text/plain', 'image/png'),
+    jupyter.plot_scale = 2,
+
+    jupyter.rich_display = TRUE,
+    jupyter.base_display_func = display_data,
+    jupyter.clear_output_func = clear_output
+  )
+
+  repos <- getOption('repos')
+  if (identical(repos, c(CRAN = '@CRAN@'))) {
+    repos[['CRAN']] <- 'https://cran.r-project.org'
+    options(repos = repos)
+  }
+}
+
+NAMESPACE <- environment()
+hera_call <- function(fn, ...) {
+    get(fn, envir = NAMESPACE)(...)
+}
+
+hera_new <- function(class, xp, ...) {
+    get(class, envir = NAMESPACE)$new(xp, ...)
+}
+
+#' Is this a running Elara jupyter kernel
+#'
+#' @return TRUE if the current session is running in an Elara kernel
+#'
+#' @examples
+#' is_elara()
+#'
+#' @export
+is_elara <- function() {
+  embedding <- getLoadedDLLs()[["(embedding)"]]
+  !is.null(embedding) && "elara_kernel_info_request" %in% names(getDLLRegisteredRoutines(embedding)$.Call)
+}
+
+hera_dot_call <- function(fn, ..., error_call = caller_env()) {
+  call <- rlang::call2(".Call", fn, ..., PACKAGE = "(embedding)")
+
+  if (!is_elara()) {
+    cli::cli_abort(c(
+      "The {.val {fn}} routine must be called inside an Elara kernel.",
+      i   = "Full internal call to the Elara routine:",
+      " " = "{deparse(call)}"
+    ), call = error_call)
+  }
+  eval.parent(call)
+}
+
+get_null_device <- function() {
+  os <- get_os()
+
+  ok_device     <- switch(os, win = png,   osx = pdf,  unix = png)
+  null_filename <- switch(os, win = 'NUL', osx = NULL, unix = '/dev/null')
+
+  null_device <- function(filename = null_filename, ...) ok_device(filename, ...)
+  null_device
+}
+
+#' @importFrom IRdisplay display
+#' @export
+IRdisplay::display

package/packages/hera/man/Comm.Rd

@@ -0,0 +1,179 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/comm.R
+\name{Comm}
+\alias{Comm}
+\title{Comm class}
+\description{
+Comm class
+}
+\section{Active bindings}{
+  \if{html}{\out{<div class="r6-active-bindings">}}
+  \describe{
+    \item{\code{id}}{id of the comm. read only.}
+
+    \item{\code{target_name}}{name of the target for this comm}
+  }
+  \if{html}{\out{</div>}}
+}
+\section{Methods}{
+\subsection{Public methods}{
+  \itemize{
+    \item \href{#method-Comm-initialize}{\code{Comm$new()}}
+    \item \href{#method-Comm-open}{\code{Comm$open()}}
+    \item \href{#method-Comm-close}{\code{Comm$close()}}
+    \item \href{#method-Comm-send}{\code{Comm$send()}}
+    \item \href{#method-Comm-on_close}{\code{Comm$on_close()}}
+    \item \href{#method-Comm-on_message}{\code{Comm$on_message()}}
+    \item \href{#method-Comm-print}{\code{Comm$print()}}
+    \item \href{#method-Comm-clone}{\code{Comm$clone()}}
+  }
+}
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-initialize"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-initialize}{}}}
+\subsection{\code{Comm$new()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$new(xp, description = "")}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{xp}}{external pointer to an instance of the C++ class 'adrastea::Comm'}
+      \item{\code{description}}{description of this comm}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-open"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-open}{}}}
+\subsection{\code{Comm$open()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$open(data = NULL, metadata = NULL, buffers = list())}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{data}}{data}
+      \item{\code{metadata}}{metadata}
+      \item{\code{buffers}}{list of raw vectors to send as binary buffers}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-close"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-close}{}}}
+\subsection{\code{Comm$close()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$close(data = NULL, metadata = NULL, buffers = list())}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{data}}{data}
+      \item{\code{metadata}}{metadata}
+      \item{\code{buffers}}{list of raw vectors to send as binary buffers}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-send"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-send}{}}}
+\subsection{\code{Comm$send()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$send(data = NULL, metadata = NULL, buffers = list())}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{data}}{data}
+      \item{\code{metadata}}{metadata}
+      \item{\code{buffers}}{list of raw vectors to send as binary buffers}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-on_close"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-on_close}{}}}
+\subsection{\code{Comm$on_close()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$on_close(handler)}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{handler}}{function to call when the comm is closed}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-on_message"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-on_message}{}}}
+\subsection{\code{Comm$on_message()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$on_message(handler)}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{handler}}{function to call when receiving a message}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-print"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-print}{}}}
+\subsection{\code{Comm$print()}}{
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$print()}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Returns}{
+    information about the comm
+  }
+}
+
+\if{html}{\out{<hr>}}
+\if{html}{\out{<a id="method-Comm-clone"></a>}}
+\if{latex}{\out{\hypertarget{method-Comm-clone}{}}}
+\subsection{\code{Comm$clone()}}{
+  The objects of this class are cloneable with this method.
+  \subsection{Usage}{
+    \if{html}{\out{<div class="r">}}
+    \preformatted{Comm$clone(deep = FALSE)}
+    \if{html}{\out{</div>}}
+  }
+  \subsection{Arguments}{
+    \if{html}{\out{<div class="arguments">}}
+    \describe{
+      \item{\code{deep}}{Whether to make a deep clone.}
+    }
+    \if{html}{\out{</div>}}
+  }
+}
+
+}