test(otel): Test newly added otel code

DESCRIPTION

@@ -91,7 +91,7 @@ Imports:
     lifecycle (>= 0.2.0),
     mime (>= 0.3),
     otel,
-    promises (>= 1.3.3.9006),
+    promises (>= 1.4.0),
     R6 (>= 2.0),
     rlang (>= 0.4.10),
     sourcetools,
@@ -120,8 +120,6 @@ Suggests:
     testthat (>= 3.2.1),
     watcher,
     yaml
-Remotes:
-    rstudio/promises
 Config/Needs/check: shinytest2
 Config/testthat/edition: 3
 Encoding: UTF-8
@@ -190,8 +188,7 @@ Collate:
     'otel-label.R'
     'otel-reactive-update.R'
     'otel-session.R'
-    'otel-with.R'
-    'otel.R'
+    'otel-shiny.R'
     'priorityqueue.R'
     'progress.R'
     'react.R'

NAMESPACE

@@ -392,6 +392,7 @@ importFrom(promises,local_ospan_promise_domain)
 importFrom(promises,promise)
 importFrom(promises,promise_reject)
 importFrom(promises,promise_resolve)
+importFrom(promises,then)
 importFrom(promises,with_ospan_async)
 importFrom(promises,with_ospan_promise_domain)
 importFrom(rlang,"%||%")

NEWS.md

@@ -38,7 +38,10 @@
 
 * 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)
+* The default label for items described below 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. This should improve the OpenTelemetry span labels and the reactlog experience. (#4269, #4300)
+  * `reactiveValues()`, `reactivePoll()`, `reactiveFileReader()`, `debounce()`, `throttle()`, `observe()`
+  * Combinations of `bindEvent()` and `reactive()` / `observe()`
+  * Combination of `bindCache()` and `reactive()`
 
 ## Changes
 

R/bind-cache.R

@@ -478,7 +478,12 @@ bindCache.default <- function(x, ...) {
 bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   check_dots_unnamed()
 
-  label <- exprToLabel(substitute(x), "cachedReactive")
+  call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
+  label <- rassignSrcrefToLabel(
+    call_srcref,
+    defaultLabel = exprToLabel(substitute(x), "cachedReactive")
+  )
+
   domain <- reactive_get_domain(x)
 
   # Convert the ... to a function that returns their evaluated values.
@@ -490,6 +495,9 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") {
   cacheHint <- rlang::hash(extractCacheHint(x))
   valueFunc <- wrapFunctionLabel(valueFunc, "cachedReactiveValueFunc", ..stacktraceon = TRUE)
 
+  x_classes <- class(x)
+  x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs
+
   # Don't hold on to the reference for x, so that it can be GC'd
   rm(x)
   # Hacky workaround for issue with `%>%` preventing GC:
@@ -498,16 +506,27 @@ bindCache.reactiveExpr <- function(x, ..., cache = "app") {
     rm(list = ".", envir = .GenericCallEnv, inherits = FALSE)
   }
 
-
-  res <- reactive(label = label, domain = domain, {
-    cache <- resolve_cache_object(cache, domain)
-    hybrid_chain(
-      keyFunc(),
-      generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook = identity, cacheWriteHook = identity)
-    )
+  with_no_otel_bind({
+    res <- reactive(label = label, domain = domain, {
+      cache <- resolve_cache_object(cache, domain)
+      hybrid_chain(
+        keyFunc(),
+        generateCacheFun(valueFunc, cache, cacheHint, cacheReadHook = identity, cacheWriteHook = identity)
+      )
+    })
   })
 
   class(res) <- c("reactive.cache", class(res))
+
+  impl <- attr(res, "observable", exact = TRUE)
+  impl$.otelAttrs <- x_otel_attrs
+  if (!is.null(call_srcref)) {
+    otelAttrs <- otel_srcref_attributes(call_srcref)
+    impl$.otelAttrs[names(otelAttrs)] <- otelAttrs
+  }
+  if (has_otel_bind("reactivity")) {
+    res <- bind_otel_reactive_expr(res)
+  }
   res
 }
 
@@ -534,6 +553,7 @@ bindCache.shiny.render.function <- function(x, ..., cache = "app") {
     )
   }
 
+  # Passes over the otelAttrs from valueFunc to renderFunc
   renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
   class(renderFunc) <- c("shiny.render.function.cache", class(valueFunc))
   renderFunc
@@ -585,7 +605,7 @@ bindCache.shiny.renderPlot <- function(x, ...,
 
     observe({
       doResizeCheck()
-    })
+    }, label = "plot-resize")
     # TODO: Make sure this observer gets GC'd if output$foo is replaced.
     # Currently, if you reassign output$foo, the observer persists until the
     # session ends. This is generally bad programming practice and should be

R/bind-event.R

@@ -196,10 +196,20 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE
   valueFunc <- reactive_get_value_func(x)
   valueFunc <- wrapFunctionLabel(valueFunc, "eventReactiveValueFunc", ..stacktraceon = TRUE)
 
-  label <- label %||%
-    sprintf('bindEvent(%s, %s)', attr(x, "observable", exact = TRUE)$.label, quos_to_label(qs))
+  call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
+  if (is.null(label)) {
+    label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = as_default_label(sprintf(
+        'bindEvent(%s, %s)',
+        attr(x, "observable", exact = TRUE)$.label,
+        quos_to_label(qs)
+      ))
+    )
+  }
 
   x_classes <- class(x)
+  x_otel_attrs <- attr(x, "observable", exact = TRUE)$.otelAttrs
 
   # Don't hold on to the reference for x, so that it can be GC'd
   rm(x)
@@ -228,6 +238,14 @@ bindEvent.reactiveExpr <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE
 
   class(res) <- c("reactive.event", x_classes)
 
+  impl <- attr(res, "observable", exact = TRUE)
+  impl$.otelAttrs <- x_otel_attrs
+  if (!is.null(call_srcref)) {
+    otelAttrs <- otel_srcref_attributes(call_srcref)
+    # Overwrite any existing attributes with these new ones
+    # (such as code.filepath, code.lineno, code.column)
+    impl$.otelAttrs[names(otelAttrs)] <- otelAttrs
+  }
   if (has_otel_bind("reactivity")) {
     res <- bind_otel_reactive_expr(res)
   }
@@ -260,6 +278,7 @@ bindEvent.shiny.render.function <- function(x, ..., ignoreNULL = TRUE, ignoreIni
     )
   }
 
+  # Passes over the otelAttrs from valueFunc to renderFunc
   renderFunc <- addAttributes(renderFunc, renderFunctionAttributes(valueFunc))
   class(renderFunc) <- c("shiny.render.function.event", class(valueFunc))
   renderFunc
@@ -280,7 +299,17 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
 
   # Note that because the observer will already have been logged by this point,
   # this updated label won't show up in the reactlog.
-  x$.label <- label %||% sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs))
+  if (is.null(label)) {
+    call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
+    x$.label <- rassignSrcrefToLabel(
+      call_srcref,
+      defaultLabel = as_default_label(
+        sprintf('bindEvent(%s, %s)', x$.label, quos_to_label(qs))
+      )
+    )
+  } else {
+    x$.label <- label
+  }
 
   initialized <- FALSE
 
@@ -313,9 +342,17 @@ bindEvent.Observer <- function(x, ..., ignoreNULL = TRUE, ignoreInit = FALSE,
   )
 
   class(x) <- c("Observer.event", class(x))
+  call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
+  if (!is.null(call_srcref)) {
+    otelAttrs <- otel_srcref_attributes(call_srcref)
+    # Overwrite any existing attributes with these new ones
+    # (such as code.filepath, code.lineno, code.column)
+    x$.otelAttrs[names(otelAttrs)] <- otelAttrs
+  }
   if (has_otel_bind("reactivity")) {
     x <- bind_otel_observe(x)
   }
+
   invisible(x)
 }
 

R/extended-task.R

@@ -119,9 +119,9 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
 
       # 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$rv_status <- reactiveVal("initial", label = "ExtendedTask$private$status")
+        private$rv_value <- reactiveVal(NULL, label = "ExtendedTask$private$value")
+        private$rv_error <- reactiveVal(NULL, label = "ExtendedTask$private$error")
       })
 
       private$invocation_queue <- fastmap::fastqueue()
@@ -134,12 +134,16 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
       call_srcref <- attr(sys.call(-1), "srcref", exact = TRUE)
       label <- rassignSrcrefToLabel(
         call_srcref,
-        defaultLabel = "<anonymous>",
-        fnName = "ExtendedTask\\$new"
+        defaultLabel = "<anonymous>"
       )
       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)
 
+      private$otel_attrs <- c(
+        otel_srcref_attributes(call_srcref),
+        otel_session_id_attrs(domain)
+      ) %||% list()
+
       set_rv_label <- function(rv, suffix) {
         impl <- attr(rv, ".impl", exact = TRUE)
         impl$.otelLabel <- otel_label_extended_task_set_reactive_val(
@@ -174,7 +178,7 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
           private$otel_label_add_to_queue,
           severity = "debug",
           attributes = c(
-            otel_session_id_attrs(getDefaultReactiveDomain()),
+            private$otel_attrs,
             list(
               queue_size = private$invocation_queue$size() + 1L
             )
@@ -186,7 +190,7 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
         if (has_otel_bind("reactivity")) {
           private$ospan <- create_shiny_ospan(
             private$otel_label,
-            attributes = otel_session_id_attrs(getDefaultReactiveDomain())
+            attributes = private$otel_attrs
           )
           otel::local_active_span(private$ospan)
         }
@@ -257,7 +261,9 @@ ExtendedTask <- R6Class("ExtendedTask", portable = TRUE, cloneable = FALSE,
     rv_value = NULL,
     rv_error = NULL,
     invocation_queue = NULL,
+
     otel_label = NULL,
+    otel_attrs = list(),
     otel_label_add_to_queue = NULL,
     ospan = NULL,
 

R/mock-session.R

@@ -436,34 +436,36 @@ MockShinySession <- R6Class(
       if (!is.function(func))
         stop(paste("Unexpected", class(func), "output for", name))
 
-      obs <- observe({
-        # We could just stash the promise, but we get an "unhandled promise error". This bypasses
-        prom <- NULL
-        tryCatch({
-          v <- private$withCurrentOutput(name, func(self, name))
-          if (!promises::is.promise(v)){
-            # Make our sync value into a promise
-            prom <- promises::promise(function(resolve, reject){ resolve(v) })
-          } else {
-            prom <- v
-          }
-        }, error=function(e){
-          # Error running value()
-          prom <<- promises::promise(function(resolve, reject){ reject(e) })
-        })
-
-        private$outs[[name]]$promise <- hybrid_chain(
-          prom,
-          function(v){
-            list(val = v, err = NULL)
-          }, catch=function(e){
-            if (
-              !inherits(e, c("shiny.custom.error", "shiny.output.cancel", "shiny.output.progress", "shiny.silent.error"))
-            ) {
-              self$unhandledError(e, close = FALSE)
+      with_no_otel_bind({
+        obs <- observe({
+          # We could just stash the promise, but we get an "unhandled promise error". This bypasses
+          prom <- NULL
+          tryCatch({
+            v <- private$withCurrentOutput(name, func(self, name))
+            if (!promises::is.promise(v)){
+              # Make our sync value into a promise
+              prom <- promises::promise(function(resolve, reject){ resolve(v) })
+            } else {
+              prom <- v
             }
-            list(val = NULL, err = e)
+          }, error=function(e){
+            # Error running value()
+            prom <<- promises::promise(function(resolve, reject){ reject(e) })
           })
+
+          private$outs[[name]]$promise <- hybrid_chain(
+            prom,
+            function(v){
+              list(val = v, err = NULL)
+            }, catch=function(e){
+              if (
+                !inherits(e, c("shiny.custom.error", "shiny.output.cancel", "shiny.output.progress", "shiny.silent.error"))
+              ) {
+                self$unhandledError(e, close = FALSE)
+              }
+              list(val = NULL, err = e)
+            })
+        })
       })
       private$outs[[name]] <- list(obs = obs, func = func, promise = NULL)
     },