feat: Add {otel} support

.vscode/settings.json

@@ -6,6 +6,7 @@
   "[r]": {
     "files.trimTrailingWhitespace": true,
     "files.insertFinalNewline": true,
+    "editor.formatOnSave": false,
   },
   "[typescript]": {
     "editor.defaultFormatter": "esbenp.prettier-vscode",

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: shiny
 Title: Web Application Framework for R
-Version: 1.11.1.9000
+Version: 1.11.1.9001
 Authors@R: c(
     person("Winston", "Chang", , "[email protected]", role = "aut",
            comment = c(ORCID = "0000-0002-1576-2126")),
@@ -94,7 +94,8 @@ Imports:
     later (>= 1.0.0),
     lifecycle (>= 0.2.0),
     mime (>= 0.3),
-    promises (>= 1.3.2),
+    otel,
+    promises (>= 1.3.3.9006),
     R6 (>= 2.0),
     rlang (>= 0.4.10),
     sourcetools,
@@ -114,6 +115,7 @@ Suggests:
     magrittr,
     markdown,
     mirai,
+    otelsdk (>= 0.2.0),
     ragg,
     reactlog (>= 1.0.0),
     rmarkdown,
@@ -122,6 +124,8 @@ Suggests:
     testthat (>= 3.2.1),
     watcher,
     yaml
+Remotes:
+    rstudio/promises
 Config/Needs/check: shinytest2
 Config/testthat/edition: 3
 Encoding: UTF-8
@@ -185,6 +189,13 @@ Collate:
     'modal.R'
     'modules.R'
     'notifications.R'
+    'otel-attr-srcref.R'
+    'otel-bind.R'
+    'otel-label.R'
+    'otel-reactive-update.R'
+    'otel-session.R'
+    'otel-with.R'
+    'otel.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'

NAMESPACE

@@ -388,9 +388,12 @@ importFrom(promises,"%...!%")
 importFrom(promises,"%...>%")
 importFrom(promises,as.promise)
 importFrom(promises,is.promising)
+importFrom(promises,local_ospan_promise_domain)
 importFrom(promises,promise)
 importFrom(promises,promise_reject)
 importFrom(promises,promise_resolve)
+importFrom(promises,with_ospan_async)
+importFrom(promises,with_ospan_promise_domain)
 importFrom(rlang,"%||%")
 importFrom(rlang,"fn_body<-")
 importFrom(rlang,"fn_fmls<-")

NEWS.md

@@ -1,5 +1,33 @@
 # shiny (development version)
 
+## OpenTelemetry support (#4269)
+
+* Added support for [OpenTelemetry](https://opentelemetry.io/) via [`{otel}`](https://otel.r-lib.org/index.html). By default, if `otel::is_tracing_enabled()` returns `TRUE`, then `{shiny}` will record all OpenTelemetery spans. See [`{otelsdk}`'s Collecting Telemetry Data](https://otelsdk.r-lib.org/reference/collecting.html) for more details on configuring OpenTelemetry.
+
+* Supported values for `options(shiny.otel.bind)` (or `Sys.getenv("SHINY_OTEL_BIND")`):
+  * `"none"` - No Shiny OpenTelemetry tracing.
+  * `"session"` - Adds session start/end spans.
+  * `"reactive_update"` - Spans for any synchronous/asynchronous reactive update. (Includes `"session"` features).
+  * `"reactivity"` - Spans for all reactive expressions. (Includes `"reactive_update"` features).
+  * `"all"` [default] - All Shiny OpenTelemetry tracing. Currently equivalent to `"reactivity"`.
+
+* Spans are recorded for:
+  * `session_start`: Wraps the calling of the `server()` function. Also contains HTTP request within the attributes.
+  * `session_end`: Wraps the calling of the `onSessionEnded()` handlers.
+  * `reactive_update`: Signals the start of when Shiny knows something is to be calculated. This span ends when there are no more reactive updates (promises or synchronous) to be calculated.
+  * `reactive`, `observe`, `output`: Captures the calculation (including any async promise chains) of a reactive expression (`reactive()`), an observer (`observe()`), or an output render function (`render*()`).
+  * `reactive debounce`, `reactive throttle`: Captures the calculation (including any async promise chains) of a `debounce()`d or `throttle()`d reactive expression.
+  * `ExtendedTask`: Captures the calculation (including any async promise chains) of an `ExtendedTask`.
+
+* OpenTelemetry Logs are recorded for:
+  * `Set reactiveVal <name>` - When a `reactiveVal()` is set
+  * `Set reactiveValues <name>$<key>` - When a `reactiveValues()` element is set
+  * Fatal or unhandled errors - When an error occurs that causes the session to end, or when an unhandled error occurs in a reactive context. Contains the error within the attributes. To unsantize the error message being collected, set `options(shiny.otel.sanitize.errors = FALSE)`.
+  * `Set ExtendedTask <name> <value>` - When an `ExtendedTask`'s respective reactive value (e.g., `status`, `value`, and `error`) is set.
+  * `<ExtendedTask name> add to queue` - When an `ExtendedTask` is added to the task queue.
+
+* All logs and spans contain the `session.id` attribute.
+
 ## New features
 
 * The `icon` argument of `updateActionButton()`/`updateActionLink()` nows allows values other than `shiny::icon()` (e.g., `fontawesome::fa()`, `bsicons::bs_icon()`, etc). (#4249)
@@ -10,9 +38,11 @@
 
 * Fixed an issue where `updateSelectizeInput(options = list(plugins="remove_button"))` could lead to multiple remove buttons. (#4275)
 
+* The default label for `reactiveValues()`, `reactivePoll()`, `reactiveFileReader()`, `debounce()`, and `throttle()` will now attempt to retrieve the assigned name if the srcref is available. If a value can not easily be produced, a default label will be used instead. (#4269)
+
 ## Changes
 
-* The return value of `actionButton()`/`actionLink()` changed slightly: `label` and `icon` are wrapped in an additional HTML container element. This allows for: 1. `updateActionButton()`/`updateActionLink()` to distinguish between the `label` and `icon` when making updates and 2. spacing between `label` and `icon` to be more easily customized via CSS. 
+* The return value of `actionButton()`/`actionLink()` changed slightly: `label` and `icon` are wrapped in an additional HTML container element. This allows for: 1. `updateActionButton()`/`updateActionLink()` to distinguish between the `label` and `icon` when making updates and 2. spacing between `label` and `icon` to be more easily customized via CSS.
 
 # shiny 1.11.1
 

R/bind-cache.R

@@ -478,7 +478,7 @@ bindCache.default <- function(x, ...) {
 bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   check_dots_unnamed()
 
-  label <- exprToLabel(substitute(key), "cachedReactive")
+  label <- exprToLabel(substitute(x), "cachedReactive")
   domain <- reactive_get_domain(x)
 
   # Convert the ... to a function that returns their evaluated values.
@@ -494,8 +494,8 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   rm(x)
   # Hacky workaround for issue with `%>%` preventing GC:
   # https://github.com/tidyverse/magrittr/issues/229
-  if (exists(".GenericCallEnv") && exists(".", envir = .GenericCallEnv)) {
-    rm(list = ".", envir = .GenericCallEnv)
+  if (exists(".GenericCallEnv") && exists(".", envir = .GenericCallEnv, inherits = FALSE)) {
+    rm(list = ".", envir = .GenericCallEnv, inherits = FALSE)
   }
 
 

R/bind-event.R

@@ -199,28 +199,39 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE
   label <- label %||%
     sprintf('bindEvent(%s, %s)', attr(x, "observable", exact = TRUE)$.label, quos_to_label(qs))
 
+  x_classes <- class(x)
+
   # Don't hold on to the reference for x, so that it can be GC'd
   rm(x)
 
   initialized <- FALSE
 
-  res <- reactive(label = label, domain = domain, ..stacktraceon = FALSE, {
-    hybrid_chain(
-      eventFunc(),
-      function(value) {
-        if (ignoreInit && !initialized) {
-          initialized <<- TRUE
-          req(FALSE)
-        }
+  with_no_otel_bind({
+    res <- reactive(label = label, domain = domain, ..stacktraceon = FALSE, {
+      hybrid_chain(
+        {
+          eventFunc()
+        },
+        function(value) {
+          if (ignoreInit && !initialized) {
+            initialized <<- TRUE
+            req(FALSE)
+          }
 
-        req(!ignoreNULL || !isNullEvent(value))
+          req(!ignoreNULL || !isNullEvent(value))
 
-        isolate(valueFunc())
-      }
-    )
+          isolate(valueFunc())
+        }
+      )
+    })
   })
 
-  class(res) <- c("reactive.event", class(res))
+  class(res) <- c("reactive.event", x_classes)
+
+  if (has_otel_bind("reactivity")) {
+    res <- bind_otel_reactive_expr(res)
+  }
+
   res
 }
 
@@ -302,6 +313,9 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
   )
 
   class(x) <- c("Observer.event", class(x))
+  if (has_otel_bind("reactivity")) {
+    x <- bind_otel_observe(x)
+  }
   invisible(x)
 }
 

R/conditions.R

@@ -556,8 +556,9 @@ dropTrivialTestFrames <- function(callnames) {
     "testthat::test_local"
   )
 
-  firstGoodCall <- min(which(!hideable))
-  toRemove <- firstGoodCall - 1L
+  # Remove everything from inception to calling the test
+  # It shouldn't matter how you get there, just that you're finally testing
+  toRemove <- max(which(hideable))
 
   c(
     rep_len(FALSE, toRemove),

R/extended-task.R

@@ -116,10 +116,41 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
     #'   read reactive inputs and pass them as arguments.
     initialize = function(func) {
       private$func <- func
-      private$rv_status <- reactiveVal("initial")
-      private$rv_value <- reactiveVal(NULL)
-      private$rv_error <- reactiveVal(NULL)
+
+      # Do not show these private reactive values in otel spans
+      with_no_otel_bind({
+        private$rv_status <- reactiveVal("initial")
+        private$rv_value <- reactiveVal(NULL)
+        private$rv_error <- reactiveVal(NULL)
+      })
+
       private$invocation_queue <- fastmap::fastqueue()
+
+      domain <- getDefaultReactiveDomain()
+
+      # Set a label for the reactive values for easier debugging
+      # Go up an extra sys.call() to get the user's call to ExtendedTask$new()
+      # The first sys.call() is to `initialize(...)`
+      call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
+      label <- rassignSrcrefToLabel(
+        call_srcref,
+        defaultLabel = "<anonymous>",
+        fnName = "ExtendedTask\\$new"
+      )
+      private$otel_label <- otel_label_extended_task(label, domain = domain)
+      private$otel_label_add_to_queue <- otel_label_extended_task_add_to_queue(label, domain = domain)
+
+      set_rv_label <- function(rv, suffix) {
+        impl <- attr(rv, ".impl", exact = TRUE)
+        impl$.otelLabel <- otel_label_extended_task_set_reactive_val(
+          label,
+          suffix,
+          domain = domain
+        )
+      }
+      set_rv_label(private$rv_status, "status")
+      set_rv_label(private$rv_value, "value")
+      set_rv_label(private$rv_error, "error")
     },
     #' @description
     #' Starts executing the long-running operation. If this `ExtendedTask` is
@@ -139,8 +170,27 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
         isolate(private$rv_status()) == "running" ||
           private$invocation_queue$size() > 0
       ) {
+        otel_log(
+          private$otel_label_add_to_queue,
+          severity = "debug",
+          attributes = c(
+            otel_session_id_attrs(getDefaultReactiveDomain()),
+            list(
+              queue_size = private$invocation_queue$size() + 1L
+            )
+          )
+        )
         private$invocation_queue$add(list(args = args, call = call))
       } else {
+
+        if (has_otel_bind("reactivity")) {
+          private$ospan <- create_shiny_ospan(
+            private$otel_label,
+            attributes = otel_session_id_attrs(getDefaultReactiveDomain())
+          )
+          otel::local_active_span(private$ospan)
+        }
+
         private$do_invoke(args, call = call)
       }
       invisible(NULL)
@@ -188,7 +238,7 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
     #' invalidation will be ignored.
     result = function() {
       switch (private$rv_status(),
-        running = req(FALSE, cancelOutput="progress"),
+        running = req(FALSE, cancelOutput = "progress"),
         success = if (private$rv_value()$visible) {
           private$rv_value()$value
         } else {
@@ -207,6 +257,9 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
     rv_value = NULL,
     rv_error = NULL,
     invocation_queue = NULL,
+    otel_label = NULL,
+    otel_label_add_to_queue = NULL,
+    ospan = NULL,
 
     do_invoke = function(args, call = NULL) {
       private$rv_status("running")
@@ -220,9 +273,17 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
       p <- promises::then(
         p,
         onFulfilled = function(value, .visible) {
+          if (is_ospan(private$ospan)) {
+            private$ospan$end(status_code = "ok")
+            private$ospan <- NULL
+          }
           private$on_success(list(value = value, visible = .visible))
         },
         onRejected = function(error) {
+          if (is_ospan(private$ospan)) {
+            private$ospan$end(status_code = "error")
+            private$ospan <- NULL
+          }
           private$on_error(error, call = call)
         }
       )

R/globals.R

@@ -25,3 +25,7 @@ on_load_exprs <- list()
 on_load <- function(expr) {
   on_load_exprs[[length(on_load_exprs) + 1]] <<- substitute(expr)
 }
+
+on_load({
+  IS_SHINY_LOCAL_PKG <- exists(".__DEVTOOLS__")
+})

R/otel-attr-srcref.R

@@ -0,0 +1,24 @@
+
+
+# Very similar to srcrefFromShinyCall(),
+# however, this works when the function does not have a srcref attr set
+otel_srcref_attributes <- function(srcref) {
+  if (is.function(srcref)) {
+    srcref <- getSrcRefs(srcref)[[1]][[1]]
+  }
+
+  if (is.null(srcref)) {
+    return(NULL)
+  }
+
+  stopifnot(inherits(srcref, "srcref"))
+
+  # Semantic conventions for code: https://opentelemetry.io/docs/specs/semconv/registry/attributes/code/
+  #
+  # Inspiration from https://github.com/r-lib/testthat/pull/2087/files#diff-92de3306849d93d6f7e76c5aaa1b0c037e2d716f72848f8a1c70536e0c8a1564R123-R124
+  dropNulls(list(
+    "code.filepath" = attr(srcref, "srcfile")$filename,
+    "code.lineno" = srcref[1],
+    "code.column" = srcref[2]
+  ))
+}