organize R code in R package

.gitignore

@@ -49,3 +49,4 @@ bld
 .virtual_documents/
 Untitled*.ipynb
 *.log
+.Rproj.user

hera/.Rbuildignore

@@ -0,0 +1,3 @@
+^hera\.Rproj$
+^\.Rproj\.user$
+^LICENSE\.md$

hera/.gitignore

@@ -0,0 +1 @@
+.Rproj.user

hera/DESCRIPTION

@@ -0,0 +1,23 @@
+Package: hera
+Title: Companion to 'Xeus-R'
+Version: 0.10.0.9000
+Authors@R: 
+    c(
+      person("Romain", "François", email = "[email protected]", role = c("aut", "cre")), 
+      person("Quantstack", role = c("cph", "fnd"))
+    )
+Description: Set of R functions to work together with Xeus-R. 
+License: MIT + file LICENSE
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.1
+Imports: 
+    cli,
+    evaluate,
+    glue,
+    IRdisplay,
+    jsonlite,
+    repr,
+    rlang,
+    tools,
+    utils

hera/LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2024
+COPYRIGHT HOLDER: Quantstack

hera/LICENSE.md

@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2024 Quantstack
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

hera/NAMESPACE

@@ -0,0 +1,5 @@
+# Generated by roxygen2: do not edit by hand
+
+export(asJSON.shiny.tag)
+import(IRdisplay)
+import(jsonlite)

hera/R/completion.R

@@ -0,0 +1,38 @@
+# This is mostly inspired from IRkernel::completions()
+# and should probably be renewed on top of something like
+# https://github.com/DavisVaughan/r-tree-sitter
+# to avoid the utils:::.completeToken system
+complete <- function(code, cursor_pos = nchar(code)) {
+  # Find which line we're on and position within that line
+  lines <- strsplit(code, '\n', fixed = TRUE)[[1]]
+  chars_before_line <- 0L
+  for (line in lines) {
+    new_cursor_pos <- cursor_pos - nchar(line) - 1L # -1 for the newline
+    if (new_cursor_pos < 0L) {
+      break
+    }
+    cursor_pos <- new_cursor_pos
+    chars_before_line <- chars_before_line + nchar(line) + 1L
+  }
+
+  # guard from errors when completion is invoked in empty cells
+  if (is.null(line)) {
+    line <- ''
+  }
+
+  utils$.assignLinebuffer(line)
+  utils$.assignEnd(cursor_pos)
+
+  info <- utils$.guessTokenFromLine(update = FALSE)
+  utils$.guessTokenFromLine()
+  utils$.completeToken()
+
+  start_position <- chars_before_line + info$start
+  comps <- utils$.retrieveCompletions()
+
+  list(
+    comps,
+    c(start_position, start_position + nchar(info$token))
+  )
+
+}

share/jupyter/kernels/xr/resources/execute.R → hera/R/execute.R

@@ -1,6 +1,9 @@
-last_plot <- NULL
-last_visible <- TRUE
-last_error <- NULL
+
+.env_private <- new.env()
+.env_private$last_plot <- NULL
+.env_private$last_visible <- TRUE
+.env_private$last_error <- NULL
+.env_private$frame_cell_execute <- NULL
 
 handle_message <- function(msg) {
   publish_stream("stderr", conditionMessage(msg))
@@ -51,12 +54,12 @@ handle_error <- function(e) {
 
     trace_back <- c(
       cli::col_red("--- Error"),
-      format(e, backtrace = FALSE), 
+      format(e, backtrace = FALSE),
       "",
-      cli::col_red("--- Traceback"), 
+      cli::col_red("--- Traceback"),
       format(e$trace)
     )
-    last_error <<- structure(list(ename = "ERROR", evalue = "", trace_back), class = "error_reply")
+    .env_private$last_error <- structure(list(ename = "ERROR", evalue = "", trace_back), class = "error_reply")
   } else {
     sys_calls <- sys.calls()
     sys_calls <- head(tail(sys_calls, -16), -3)
@@ -65,12 +68,12 @@ handle_error <- function(e) {
     evalue <- paste(conditionMessage(e), collapse = "\n")
     trace_back <- c(
       cli::col_red("--- Error"),
-      evalue, 
+      evalue,
       "",
-      cli::col_red("--- Traceback (most recent call last)"), 
+      cli::col_red("--- Traceback (most recent call last)"),
       stack
     )
-    last_error <<- structure(list(ename = "ERROR", evalue = evalue, trace_back), class = "error_reply")
+    .env_private$last_error <- structure(list(ename = "ERROR", evalue = evalue, trace_back), class = "error_reply")
   }
 }
 
@@ -79,7 +82,7 @@ handle_value <- function(obj, visible) {
 
   if (visible && inherits(obj, "ggplot")) {
     print(obj)
-    last_visible <<- FALSE
+    .env_private$last_visible <- FALSE
   }
 
 }
@@ -89,12 +92,12 @@ handle_graphics <- function(plot) {
   attr(plot, ".irkernel_height") <- getOption('repr.plot.height', repr::repr_option_defaults$repr.plot.height)
   attr(plot, ".irkernel_res")    <- getOption('repr.plot.res', repr::repr_option_defaults$repr.plot.res)
   attr(plot, ".irkernel_ppi")    <- attr(plot, ".irkernel_res") / getOption('jupyter.plot_scale', 2)
-  
-  if (!plot_builds_upon(last_plot, plot)) {
-    send_plot(last_plot)
+
+  if (!plot_builds_upon(.env_private$last_plot, plot)) {
+    send_plot(.env_private$last_plot)
   }
 
-  last_plot <<- plot
+  .env_private$last_plot <- plot
 }
 
 send_plot <- function(plot) {
@@ -111,8 +114,8 @@ send_plot <- function(plot) {
 
     if (!identical(mime, 'text/plain')) {
       metadata[[mime]] <- list(
-          width  = w * ppi,
-          height = h * ppi
+        width  = w * ppi,
+        height = h * ppi
       )
     }
 
@@ -127,51 +130,51 @@ send_plot <- function(plot) {
 }
 
 execute <- function(code, execution_counter, silent = FALSE) {
-  last_error <<- NULL
-  
+  .env_private$last_error <- NULL
+
   parsed <- tryCatch(
-    parse(text = code), 
+    parse(text = code),
     error = function(e) {
       msg <- paste(conditionMessage(e), collapse = "\n")
-      last_error <<- structure(list(ename = "PARSE ERROR", evalue = msg), class = "error_reply")
+      .env_private$last_error <- structure(list(ename = "PARSE ERROR", evalue = msg), class = "error_reply")
     }
   )
-  if (!is.null(last_error)) return(last_error)
-  
+  if (!is.null(.env_private$last_error)) return(.env_private$last_error)
+
   output_handler <- if (silent) {
     evaluate::new_output_handler()
   } else {
     evaluate::new_output_handler(
-      text = function(txt) publish_stream("stdout", txt), 
+      text = function(txt) publish_stream("stdout", txt),
       graphics = handle_graphics,
-      message = handle_message, 
-      warning = handle_warning, 
-      error = handle_error, 
+      message = handle_message,
+      warning = handle_warning,
+      error = handle_error,
       value = handle_value
-    )  
+    )
   }
-  
-  last_plot <<- NULL
-  last_visible <<- FALSE
+
+  .env_private$last_plot <- NULL
+  .env_private$last_visible <- FALSE
 
   filename <- glue::glue("[{execution_counter}]")
 
-  frame_cell_execute <<- environment()
+  .env_private$frame_cell_execute <- environment()
   evaluate::evaluate(
     code,
     envir = globalenv(),
     output_handler = output_handler,
-    stop_on_error = 1L, 
+    stop_on_error = 1L,
     filename = filename
   )
-  if (!is.null(last_error)) return(last_error)
+  if (!is.null(.env_private$last_error)) return(.env_private$last_error)
 
-  if (!silent && !is.null(last_plot)) {
-    tryCatch(send_plot(last_plot), error = handle_error)
+  if (!silent && !is.null(.env_private$last_plot)) {
+    tryCatch(send_plot(.env_private$last_plot), error = handle_error)
   }
-  if (!is.null(last_error)) return(last_error)
+  if (!is.null(.env_private$last_error)) return(.env_private$last_error)
 
-  if (isTRUE(last_visible)) {
+  if (isTRUE(.env_private$last_visible)) {
     obj <- .Last.value
 
     # TODO: This probably needs to be generalized
@@ -180,11 +183,11 @@ execute <- function(code, execution_counter, silent = FALSE) {
     } else {
       "text/plain"
     }
-    
+
     bundle <- IRdisplay::prepare_mimebundle(obj, mimetypes = mimetypes)
-    
-    structure(class = "execution_result", 
-      list(toJSON(bundle$data), toJSON(bundle$metadata))
+
+    structure(class = "execution_result",
+              list(toJSON(bundle$data), toJSON(bundle$metadata))
     )
   }
 

hera/R/inspect.R

@@ -0,0 +1,69 @@
+inspect <- function(code, cursor_pos) {
+  # 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 = .GlobalEnv), 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), metadata = NULL)
+}

hera/R/jsonlite.R

@@ -0,0 +1,4 @@
+#' @export
+asJSON.shiny.tag <- function(x, ...) {
+  jsonlite:::asJSON(as.character(x), ...)
+}

hera/R/log.R

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